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-2026 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 170     170   1058 use Date::Manip::Obj;
  170         359  
  170         9562  
15             @ISA = ('Date::Manip::Obj');
16              
17             require 5.010000;
18 170     170   842 use warnings;
  170         351  
  170         8475  
19 170     170   766 use strict;
  170         320  
  170         3568  
20 170     170   590 use integer;
  170         326  
  170         1361  
21 170     170   3710 use utf8;
  170         356  
  170         1035  
22 170     170   4196 use IO::File;
  170         387  
  170         25601  
23             #use re 'debug';
24              
25 170     170   921 use Date::Manip::Base;
  170         366  
  170         4097  
26 170     170   645 use Date::Manip::TZ;
  170         348  
  170         2118138  
27              
28             our $VERSION;
29             $VERSION='6.99';
30 170     170   2833 END { undef $VERSION; }
31              
32             ########################################################################
33             # BASE METHODS
34             ########################################################################
35              
36             sub is_recur {
37 1     1 1 90 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 1720     1720   2580 my($self) = @_;
45 1720         3040 my $dmt = $$self{'tz'};
46 1720         2238 my $dmb = $$dmt{'base'};
47              
48 1720         2515 $$self{'err'} = '';
49              
50 1720         2568 $$self{'data'}{'freq'} = ''; # The frequency
51 1720         3076 $$self{'data'}{'flags'} = []; # Modifiers
52 1720         3428 $$self{'data'}{'base'} = undef; # The specified base date
53 1720         2561 $$self{'data'}{'BASE'} = undef; # The actual base date
54 1720         3133 $$self{'data'}{'start'} = undef; # Start and end date
55 1720         3064 $$self{'data'}{'end'} = undef;
56 1720         2383 $$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 1720         2550 $$self{'data'}{'interval'} = []; # (Y, M, ...)
61 1720         3156 $$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
62             # [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
63             # ... )
64 1720         2457 $$self{'data'}{'slow'} = 0; # 1 if a range of the form 2--2 is
65             # included.
66 1720         2496 $$self{'data'}{'ev_per_d'} = 0; # The number of events per interval date.
67 1720         3950 $$self{'data'}{'delta'} = undef; # The offset based on the interval.
68 1720         2196 $$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 1720         5706 $$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 1720         5737 $$self{'data'}{'dates'} = {}; # { N => Nth recurring event }
81             # N is relative to the base date and is
82             # not affected by start/end
83 1720         2329 $$self{'data'}{'curr'} = undef; # Iterator pointer
84 1720         2348 $$self{'data'}{'first'} = undef; # N : the first date in a range
85 1720         2156 $$self{'data'}{'last'} = undef; # N : the last date in a range
86              
87             # Get the default start/end dates
88              
89 1720         5325 my $range = $dmb->_config('recurrange');
90              
91 1720 50       3891 if ($range eq 'none') {
    0          
    0          
    0          
    0          
    0          
92 1720         2179 $$self{'data'}{'start'} = undef;
93 1720         2736 $$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   2602 my($self,$keep) = @_;
153              
154 1603 100       2595 if (! $keep) {
155 1097         2220 $$self{'data'}{'base'} = undef;
156 1097         1630 $$self{'data'}{'BASE'} = undef;
157 1097         11423 $$self{'data'}{'idate'} = {};
158 1097         7937 $$self{'data'}{'dates'} = {};
159             }
160 1603         2400 $$self{'data'}{'curr'} = undef;
161 1603         2284 $$self{'data'}{'first'} = undef;
162 1603         2537 $$self{'data'}{'last'} = undef;
163             }
164              
165             sub _init_args {
166 2     2   9 my($self) = @_;
167              
168 2         16 my @args = @{ $$self{'args'} };
  2         11  
169 2         20 $self->parse(@args);
170             }
171              
172             ########################################################################
173             # METHODS
174             ########################################################################
175              
176             sub parse {
177 487     487 1 469296 my($self,$string,@args) = @_;
178 487         1374 $self->_init();
179              
180             # Test if $string = FREQ
181              
182 487         1255 my $err = $self->frequency($string);
183 487 100       933 if (! $err) {
184 364         501 $string = '';
185             }
186              
187             # Test if $string = "FREQ*..." and FREQ contains an '*'.
188              
189 487 100       844 if ($err) {
190 123         602 $self->err(1);
191              
192 123         877 $string =~ s/\s*\*\s*/\*/g;
193              
194 123 50       470 if ($string =~ /^([^*]*\*[^*]*)\*/) {
195             # Everything up to the 2nd '*'
196 123         330 my $freq = $1;
197 123         243 $err = $self->frequency($freq);
198 123 50       260 if (! $err) {
199 123         2227 $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       962 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       843 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         928 my @string = split(/\*/,$string);
231              
232 487 100       834 if (@string) {
233 123         206 my $tmp = shift(@string);
234 123 100       394 $err = $self->modifiers($tmp) if ($tmp);
235 123 50       248 return 1 if ($err);
236             }
237              
238 487 100       787 if (@args) {
239 266         356 my $tmp = $args[0];
240 266 100 66     732 if ($tmp && ! ref($tmp)) {
241 207         616 $err = $self->modifiers($tmp);
242 207 100       420 shift(@args) if (! $err);
243             }
244             }
245              
246             # Handle BASE
247              
248 487 100       852 if (@string) {
249 25         58 my $tmp = shift(@string);
250 25 100 66     162 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
251 25 50       70 return 1 if ($err);
252             }
253 487 100       4455 if (@args) {
254 265         371 my $tmp = shift(@args);
255 265 100 66     894 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
256 265 50       545 return 1 if ($err);
257             }
258              
259             # Handle START, END, UNMOD
260              
261 487 100       894 if (@string) {
262 24         51 my($start) = shift(@string);
263 24         51 my($end) = shift(@string);
264 24         74 my($unmod) = shift(@string);
265              
266 24 50 33     302 $err = $self->start($start,$unmod) if (defined($start) && $start);
267 24 50       87 return 1 if ($err);
268              
269 24 50 33     208 $err = $self->end($end) if (defined($end) && $end);
270 24 50       92 return 1 if ($err);
271             }
272 487 100       823 if (@args) {
273 265         473 my($start) = shift(@args);
274 265         438 my($end) = shift(@args);
275 265         343 my($unmod) = shift(@args);
276              
277 265 100 66     1138 $err = $self->start($start,$unmod) if (defined($start) && $start);
278 265 50       515 return 1 if ($err);
279              
280 265 100 66     1116 $err = $self->end($end) if (defined($end) && $end);
281 265 50       617 return 1 if ($err);
282             }
283              
284             # Remaining arguments are invalid.
285              
286 487 50       819 if (@string) {
287 0         0 $$self{'err'} = "[parse] String contains invalid elements";
288 0         0 return 1;
289             }
290 487 50       760 if (@args) {
291 0         0 $$self{'err'} = "[parse] Unknown arguments";
292 0         0 return 1;
293             }
294              
295 487         1255 return 0;
296             }
297              
298             sub frequency {
299 942     942 1 411931 my($self,$string) = @_;
300 942 50       1617 return $$self{'data'}{'freq'} if (! defined $string);
301              
302 942         1889 $self->_init();
303 942         1113 my (@int,@rtime);
304              
305             PARSE: {
306              
307             # Standard frequency notation
308              
309 942         994 my $stdrx = $self->_rx('std');
  942         2131  
310 942 100       9682 if ($string =~ $stdrx) {
311 782         6534 my($l,$r) = @+{qw(l r)};
312              
313 782 50       2121 if (defined($l)) {
314 782         1724 $l =~ s/^\s*:/0:/;
315 782         1487 $l =~ s/:\s*$/:0/;
316 782         1032 $l =~ s/::/:0:/g;
317              
318 782         1687 @int = split(/:/,$l);
319             }
320              
321 782 50       1355 if (defined($r)) {
322 782         1704 $r =~ s/^\s*:/0:/;
323 782         1958 $r =~ s/:\s*$/:0/;
324 782         1106 $r =~ s/::/:0:/g;
325              
326 782         1460 @rtime = split(/:/,$r);
327             }
328              
329 782         1545 last PARSE;
330             }
331              
332             # Other frequency strings
333              
334             # Strip out some words to ignore
335              
336 160         321 my $ignrx = $self->_rx('ignore');
337 160         1321 $string =~ s/$ignrx/ /g;
338              
339 160         338 my $eachrx = $self->_rx('each');
340 160         246 my $each = 0;
341 160 100       1101 if ($string =~ s/$eachrx/ /g) {
342 28         39 $each = 1;
343             }
344              
345 160         1007 $string =~ s/\s*$//;
346              
347 160 50       348 if (! $string) {
348 0         0 $$self{'err'} = "[frequency] Invalid frequency string";
349 0         0 return 1;
350             }
351              
352 160         3909 my $err = $self->_parse_lang($string);
353 160 100       381 if ($err) {
354 128         248 $$self{'err'} = "[frequency] Invalid frequency string";
355 128         286 return 1;
356             }
357 32         73 return 0;
358             }
359              
360             # If the interval consists only of zeros, the last entry is changed
361             # to 1.
362              
363 782 100       1355 if (@int) {
364 552         829 for my $i (@int) {
365 1078         1564 $i += 0;
366             }
367              
368             TEST_INT: {
369 552         4372 for my $i (@int) {
  552         867  
370 787 100       1766 last TEST_INT if ($i);
371             }
372 75         116 $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     3589 while (@int &&
      100        
      100        
382             ($#int == 1 || $#int == 2) &&
383             ($int[$#int] == 0)) {
384 101         130 pop(@int);
385 101         390 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         1996 my @ftype = ('y','m','w','d','h','mn','s');
405 782         1560 my @vtype = ('' ,'' ,'' ,'' ,'' ,'' ,'');
406              
407 782         1765 my ($y,$m,$w,$d,$h,$mn,$s) = (@int,@rtime);
408              
409 782 100       1404 if (@rtime == 7) {
410 230         278 $vtype[0] = 'y';
411             }
412              
413 782 100       1447 if (@rtime >= 6) {
414 547 100       1040 if ($m) {
415 371         558 $vtype[1] = 'moy';
416             } else {
417 176         225 $vtype[1] = 'zero';
418             }
419             }
420              
421 782 100       1488 if (@rtime >= 5) {
422 685 100       1048 if ($w) {
423 329 100       445 if ($m) {
424 226         345 $vtype[2] = 'wom';
425             } else {
426 103         124 $vtype[2] = 'woy';
427             }
428             } else {
429 356         491 $vtype[2] = 'zero';
430             }
431             }
432              
433 782 100       1292 if (@rtime >= 4) {
434 727 100       1120 if ($d) {
435 528 100       955 if ($w) {
    100          
436 226         270 $vtype[3] = 'dow';
437             } elsif ($m) {
438 247         325 $vtype[3] = 'dom';
439             } else {
440 55         78 $vtype[3] = 'doy';
441             }
442             } else {
443 199         326 $vtype[3] = 'zero';
444             }
445             }
446              
447 782 100       1216 if (@rtime >= 3) {
448 766         922 $vtype[4] = 'time';
449             }
450 782 100       1161 if (@rtime >= 2) {
451 771         815 $vtype[5] = 'time';
452             }
453 782 100       1207 if (@rtime) {
454 771         822 $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         1362 my $rfieldrx = $self->_rx('rfield');
466 782         1247 my $rrangerx = $self->_rx('rrange');
467              
468 782         990 my $i = -1;
469 782         1181 foreach my $f (@int,@rtime) {
470 4772         4238 $i++;
471 4772         4744 my $vtype = $vtype[$i];
472 4772         4504 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       6234 next if (! $vtype);
480              
481 3795 100 100     13431 if ($f && $f !~ $rfieldrx) {
482 1         3 $$self{'err'} = "[frequency] Invalid rtime string";
483 1         6 return 1;
484             }
485              
486 3794         4985 my @rfield = split(/,/,$f);
487 3794         3558 my @val;
488              
489 3794         3828 foreach my $vals (@rfield) {
490 3858 100       7290 if ($vals =~ $rrangerx) {
491 73         253 my ($num1,$num2) = ($1+0,$2+0);
492              
493 73         187 my $err = $self->_frequency_values($num1,$type,$vtype);
494 73 100       151 return $err if ($err);
495              
496 72         110 $err = $self->_frequency_values($num2,$type,$vtype);
497 72 50       124 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       122 if ($num1 > $num2) {
502 2         3 $$self{'err'} = "[frequency] Invalid rtime range string";
503 2         10 return 1;
504             }
505 64         176 push(@val,$num1..$num2);
506             } else {
507 6         17 push(@val,[$num1,$num2]);
508             }
509              
510             } else {
511 3785         4379 $vals += 0;
512              
513 3785         5520 my $err = $self->_frequency_values($vals,$type,$vtype);
514 3785 100       5110 return $err if ($err);
515              
516 3609         4657 push(@val,$vals);
517             }
518             }
519              
520 3615         6315 $f = [ @val ];
521             }
522              
523             # Store it
524              
525 602         1200 $$self{'data'}{'interval'} = [ @int ];
526 602         1361 $$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         1718 my $freq = join(':',@int);
532 602         688 my $slow = 0;
533 602         682 my $n = 1;
534 602 100       924 if (@rtime) {
535 591         744 $freq .= '*';
536 591         639 my (@tmp);
537              
538 591         720 foreach my $rtime (@rtime) {
539 3418         2918 my @t2;
540 3418         3474 foreach my $tmp (@$rtime) {
541 3694 100       3841 if (ref($tmp)) {
542 6         13 my($a,$b) = @$tmp;
543 6         17 push(@t2,"$a-$b");
544 6         11 $slow = 1;
545             } else {
546 3688         4121 push(@t2,$tmp);
547             }
548             }
549 3418         3985 my $tmp = join(',',@t2);
550 3418         3917 push(@tmp,$tmp);
551 3418         3234 my $nn = @t2;
552 3418         3879 $n *= $nn;
553             }
554 591         1342 $freq .= join(':',@tmp);
555             }
556 602         1064 $$self{'data'}{'freq'} = $freq;
557 602         906 $$self{'data'}{'slow'} = $slow;
558 602 100       1159 $$self{'data'}{'ev_per_d'} = $n if (! $slow);
559              
560 602 100       867 if (@int) {
561 436         580 $$self{'data'}{'noint'} = 0;
562              
563 436         752 while (@int < 7) {
564 2256         2878 push(@int,0);
565             }
566 436         1509 my $delta = $self->new_delta();
567 436         1756 $delta->set('delta',[@int]);
568 436         1049 $$self{'data'}{'delta'} = $delta;
569              
570             } else {
571 166         225 $$self{'data'}{'noint'} = 1;
572             }
573              
574 602         2351 return 0;
575             }
576              
577             sub _frequency_values {
578 3930     3930   5060 my($self,$num,$type,$vtype) = @_;
579 3930         3582 my $err;
580              
581 3930 100       7974 if ($type eq 'y') {
    100          
    100          
    100          
    100          
582 248 50       435 if ($vtype eq 'y') {
583 248 100 100     813 if ($num < 0 || $num > 9999) {
584 16         24 $$self{'err'} = "[frequency] Year must be in the range 1-9999";
585 16         24 return 1;
586             }
587             }
588              
589             } elsif ($type eq 'm') {
590 572 100       1078 if ($vtype eq 'moy') {
591 404 100 100     1177 if ($num < 1 || $num > 12) {
592 34         45 $$self{'err'} = "[frequency] Month of year must be 1-12";
593 34         65 return 1;
594             }
595             }
596              
597             } elsif ($type eq 'w') {
598 670 100       1448 if ($vtype eq 'woy') {
    100          
599 103 100 66     435 if ($num == 0 || $num > 53 || $num < -53) {
      100        
600 22         29 $$self{'err'} = "[frequency] Week of year must be 1-53 or -1 to -53";
601 22         35 return 1;
602             }
603              
604             } elsif ($vtype eq 'wom') {
605 235 100 66     988 if ($num == 0 || $num > 5 || $num < -5) {
      100        
606 31         37 $$self{'err'} = "[frequency] Week of month must be 1-5 or -1 to -5";
607 31         45 return 1;
608             }
609              
610             }
611              
612             } elsif ($type eq 'd') {
613 635 100       1547 if ($vtype eq 'dow') {
    100          
    100          
614 190 100 100     604 if ($num < 1 || $num > 7) {
615 36         45 $$self{'err'} = "[frequency] Day of week must be 1-7";
616 36         45 return 1;
617             }
618              
619             } elsif ($vtype eq 'dom') {
620 245 100 66     1166 if ($num == 0 || $num > 31 || $num < -31) {
      100        
621 20         28 $$self{'err'} = "[frequency] Day of month must be 1-31 or -1 to -31";
622 20         29 return 1;
623             }
624              
625             } elsif ($vtype eq 'doy') {
626 55 100 66     271 if ($num == 0 || $num > 366 || $num < -366) {
      100        
627 14         21 $$self{'err'} = "[frequency] Day of year must be 1-366 or -1 to -366";
628 14         21 return 1;
629             }
630             }
631              
632             } elsif ($type eq 'h') {
633 614 50       1054 if ($vtype eq 'time') {
634 614 100 66     1676 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       1790 if ($vtype eq 'time') {
642 1191 100 66     2738 if ($num < 0 || $num > 59) {
643 3         5 $$self{'err'} = "[frequency] Minute/second must be 0-59";
644 3         4 return 1;
645             }
646             }
647             }
648              
649 3753         4505 return 0;
650             }
651              
652             sub _parse_lang {
653 160     160   277 my($self,$string) = @_;
654 160         255 my $dmt = $$self{'tz'};
655 160         211 my $dmb = $$dmt{'base'};
656              
657             # Test the regular expression
658              
659 160         4280 my $rx = $self->_rx('every');
660              
661 160 100       3074 return 1 if ($string !~ $rx);
662             my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) =
663 32         665 @+{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         124 my $dow;
668 32 100 66     103 if (defined($day_name) || defined($day_abb)) {
669 16 50       30 if (defined($day_name)) {
670 16         54 $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         32 my $mmm;
677 32 100 66     104 if (defined($mon_name) || defined($mon_abb)) {
678 8 50       17 if (defined($mon_name)) {
679 8         21 $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       58 if (defined($nth)) {
686 14         49 $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
687             }
688              
689             # Get the frequencies
690              
691 32         54 my($freq);
692 32 100       64 if (defined($dow)) {
    50          
693 16 100       30 if (defined($mmm)) {
694 8 100       20 if (defined($last)) {
    100          
695             # last DoW in MMM [YY]
696 2         5 $freq = "1*$mmm:-1:$dow:0:0:0";
697              
698             } elsif (defined($nth)) {
699             # Nth DoW in MMM [YY]
700 4         11 $freq = "1*$mmm:$nth:$dow:0:0:0";
701              
702             } else {
703             # every DoW in MMM [YY]
704 2         6 $freq = "1*$mmm:1-5:$dow:0:0:0";
705             }
706              
707             } else {
708 8 100       20 if (defined($last)) {
    100          
709             # last DoW in every month [in YY]
710 2         5 $freq = "0:1*-1:$dow:0:0:0";
711              
712             } elsif (defined($nth)) {
713             # Nth DoW in every month [in YY]
714 4         11 $freq = "0:1*$nth:$dow:0:0:0";
715              
716             } else {
717             # every DoW in every month [in YY]
718 2         4 $freq = "0:1*1-5:$dow:0:0:0";
719             }
720             }
721              
722             } elsif (defined($day)) {
723 16 100       27 if (defined($month)) {
724 8 100       19 if (defined($nth)) {
    100          
725             # Nth day of every month [YY]
726 4         9 $freq = "0:1*0:$nth:0:0:0";
727              
728             } elsif (defined($last)) {
729             # last day of every month [YY]
730 2         3 $freq = "0:1*0:-1:0:0:0";
731              
732             } else {
733             # every day of every month [YY]
734 2         3 $freq = "0:0:0:1*0:0:0";
735             }
736              
737             } else {
738 8 100       15 if (defined($nth)) {
    100          
739             # every Nth day [YY]
740 2         5 $freq = "0:0:0:$nth*0:0:0";
741              
742             } elsif (defined($n)) {
743             # every N days [YY]
744 4         8 $freq = "0:0:0:$n*0:0:0";
745              
746             } else {
747             # every day [YY]
748 2         4 $freq = "0:0:0:1*0:0:0";
749             }
750             }
751             }
752              
753             # Get the range (if YY is included)
754              
755 32 100       69 if (defined($y)) {
756 18         72 $y = $dmt->_fix_year($y);
757 18         177 my $start = "${y}010100:00:00";
758 18         28 my $end = "${y}123123:59:59";
759              
760 18         57 return $self->parse($freq,undef,$start,$end);
761             }
762              
763 14         34 return $self->frequency($freq)
764             }
765              
766             sub _date {
767 679     679   1058 my($self,$op,$date_or_string) = @_;
768              
769             # Make sure the argument is a date
770              
771 679 50       1409 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         1725 my $date = $self->new_date();
780 679         1802 my $err = $date->parse($date_or_string);
781 679 50       1092 if ($err) {
782 0         0 $$self{'err'} = "[$op] Invalid date string";
783 0         0 return 1;
784             }
785 679         1798 $$self{'data'}{$op} = $date;
786             }
787              
788 679         1305 return 0;
789             }
790              
791             sub start {
792 1019     1019 1 2144 my($self,$start,$unmod) = @_;
793 1019 100       3686 return $$self{'data'}{'start'} if (! defined $start);
794              
795 253         795 $self->_init_dates(1);
796 253         366 $$self{'data'}{'unmod_range'} = $unmod;
797 253         523 $self->_date('start',$start);
798             }
799              
800             sub end {
801 337     337 1 936 my($self,$end) = @_;
802 337 100       839 return $$self{'data'}{'end'} if (! defined $end);
803              
804 253         739 $self->_init_dates(1);
805 253         518 $self->_date('end',$end);
806             }
807              
808             sub basedate {
809 173     173 1 1492 my($self,$base) = @_;
810 173 50       312 return ($$self{'data'}{'base'},$$self{'data'}{'BASE'}) if (! defined $base);
811              
812 173         476 $self->_init_dates();
813 173         417 $self->_date('base',$base);
814             }
815              
816             sub modifiers {
817 309     309 1 645 my($self,@flags) = @_;
818 309 50       520 return @{ $$self{'data'}{'flags'} } if (! @flags);
  0         0  
819              
820 309         443 my $dmt = $$self{'tz'};
821 309         429 my $dmb = $$dmt{'base'};
822 309 50       579 if (@flags == 1) {
823 309         683 @flags = split(/,/,lc($flags[0]));
824             }
825              
826             # Add these flags to the list
827              
828 309 50 33     1000 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         506 foreach my $flag (@flags) {
837 322 100       1341 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         271 $$self{'err'} = "[modifiers] Invalid modifier: $flag";
839 151         326 return 1;
840             }
841              
842 158         356 $$self{'data'}{'flags'} = [ @flags ];
843 158         532 $self->_init_dates();
844              
845 158         242 return 0;
846             }
847              
848             sub nth {
849 2097     2097 1 5833 my($self,$n) = @_;
850 2097 100       3376 $n = 0 if (! $n);
851             return ($$self{'data'}{'dates'}{$n},0)
852 2097 100       5345 if (exists $$self{'data'}{'dates'}{$n});
853              
854 86         158 my ($err) = $self->_error();
855 86 50       139 return (undef,$err) if ($err);
856              
857             return ($$self{'data'}{'dates'}{$n},0)
858 86 100       165 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       162 if ($$self{'data'}{'noint'}) {
863 4         9 return (undef,0);
864             }
865              
866 80 100       142 if ($$self{'data'}{'slow'}) {
867 2         2 my $nn = 0;
868 2         3 while (1) {
869 4         8 $self->_nth_interval($nn);
870             return ($$self{'data'}{'dates'}{$n},0)
871 4 100       18 if (exists $$self{'data'}{'dates'}{$n});
872 2 50       5 if ($n >= 0) {
873 2         4 $nn++;
874             } else {
875 0         0 $nn--;
876             }
877             }
878              
879             } else {
880 78         83 my $nn;
881 78 100       128 if ($n >= 0) {
882 74         128 $nn = int($n/$$self{'data'}{'ev_per_d'});
883             } else {
884 4         11 $nn = int(($n+1)/$$self{'data'}{'ev_per_d'}) -1;
885             }
886 78         162 $self->_nth_interval($nn);
887 78         170 return ($$self{'data'}{'dates'}{$n},0);
888             }
889             }
890              
891             sub next {
892 8     8 1 787 my($self) = @_;
893              
894 8         21 my ($err) = $self->_error();
895 8 50       19 return (undef,$err) if ($err);
896              
897             # If curr is not set, we have to get it.
898              
899 8 100       17 if (! defined $$self{'data'}{'curr'}) {
900              
901             CURR:
902 5         22 while (1) {
903              
904             # If no interval then
905             # return base date
906              
907 5 100       10 if ($$self{'data'}{'noint'}) {
908 1         2 $$self{'data'}{'curr'} = -1;
909 1         3 last CURR;
910             }
911              
912             # If a range is defined
913             # find first event in range and return it
914              
915 4 100 66     18 if (defined $$self{'data'}{'start'} &&
916             defined $$self{'data'}{'end'}) {
917              
918 2         8 my $n = $self->_locate_n('first');
919 2 100 66     14 return (undef,'Not found') if ($$self{'err'} || ! defined($n));
920 1         4 $$self{'data'}{'curr'} = $n-1;
921              
922             } else {
923 2         5 $$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         24 while (1) {
932 9         10 $$self{'data'}{'curr'}++;
933 9 100       17 if ($$self{'data'}{'noint'}) {
934             return (undef,0)
935 3 100       9 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
936             }
937 8         18 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
938 8 50       14 return (undef,$e) if ($e);
939 8 100       24 return ($d,0) if (defined $d);
940             }
941             }
942              
943             sub prev {
944 11     11 1 1098 my($self) = @_;
945              
946 11         35 my ($err) = $self->_error();
947 11 50       35 return (undef,$err) if ($err);
948              
949             # If curr is not set, we have to get it.
950              
951 11 100       25 if (! defined $$self{'data'}{'curr'}) {
952              
953             CURR:
954 5         7 while (1) {
955              
956             # If no interval then
957             # return last one
958              
959 5 100       32 if ($$self{'data'}{'noint'}) {
960 1         2 my @n = sort { $a <=> $b } keys %{ $$self{'data'}{'dates'} };
  1         3  
  1         5  
961 1         3 $$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     26 if (defined $$self{'data'}{'start'} &&
969             defined $$self{'data'}{'end'}) {
970              
971 2         9 my $n = $self->_locate_n('last');
972 2 100 66     17 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         9 while (1) {
985 11         17 $$self{'data'}{'curr'}--;
986 11 100       20 if ($$self{'data'}{'noint'}) {
987             return (undef,0)
988 6 100       16 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
989             }
990 9         21 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
991 9 50       18 return (undef,$e) if ($e);
992 9 100       31 return ($d,0) if (defined $d);
993             }
994             }
995              
996             sub dates {
997 1181     1181 1 3271 my($self,$start2,$end2,$unmod) = @_;
998 1181         3455 $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         1308 my $tmp_limits = 0;
1004 1181 100 100     2914 $tmp_limits = 1 if ($start2 || $end2);
1005 1181 100       2096 $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         1316 my $range_required;
1011 1181 100 100     2904 if (defined($start2) && defined($end2)) {
1012 735         889 $range_required = 0;
1013             } else {
1014 446         584 $range_required = 1;
1015             }
1016              
1017 1181         1193 my($err);
1018 1181         2734 ($err,$start2,$end2) = $self->_error($range_required,$start2,$end2);
1019 1181 100       2133 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         1519 my ($old_start, $old_end, $old_first, $old_last, $old_unmod);
1025              
1026 1174 100       2101 if ($tmp_limits) {
1027 737         1260 $old_start = $$self{'data'}{'start'};
1028 737         1045 $old_end = $$self{'data'}{'end'};
1029 737         1040 $old_first = $$self{'data'}{'first'};
1030 737         991 $old_last = $$self{'data'}{'last'};
1031 737         1076 $old_unmod = $$self{'data'}{'unmod_range'};
1032              
1033 737         1067 $$self{'data'}{'start'} = $start2;
1034 737         996 $$self{'data'}{'end'} = $end2;
1035 737         1038 $$self{'data'}{'first'} = undef;
1036 737         943 $$self{'data'}{'last'} = undef;
1037 737         960 $$self{'data'}{'unmod_range'} = $unmod;
1038             }
1039              
1040             # Get all of the dates
1041              
1042 1174         1416 my($end,$first,$last,@dates);
1043              
1044 1174         2926 $first = $self->_locate_n('first');
1045 1174 100       2877 return () if ($$self{'err'});
1046 1173         2563 $last = $self->_locate_n('last');
1047 1173 50       2312 return () if ($$self{'err'});
1048              
1049 1173 100 66     3120 if (defined($first) && defined($last)) {
1050 1068         2270 for (my $n = $first; $n <= $last; $n++) {
1051 2050         3838 my($date,$err) = $self->nth($n);
1052 2050 100       5184 push(@dates,$date) if (defined $date);
1053             }
1054             }
1055              
1056             # Restore the original date range values.
1057              
1058 1173 100       1890 if ($tmp_limits) {
1059 737         1205 $$self{'data'}{'start'} = $old_start;
1060 737         1104 $$self{'data'}{'end'} = $old_end;
1061 737         999 $$self{'data'}{'first'} = $old_first;
1062 737         964 $$self{'data'}{'last'} = $old_last;
1063 737         1001 $$self{'data'}{'unmod_range'} = $old_unmod;
1064             }
1065              
1066 1173         7249 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   2044 my($self,$range_required,$start2,$end2) = @_;
1078              
1079 1286 50       2245 return ('Invalid recurrence') if ($self->err());
1080              
1081             # All dates entered must be valid.
1082              
1083 1286         1708 my($start,$end);
1084 1286 100       2623 if (defined $start2) {
    100          
1085 736 100       1668 if (ref($start2) eq 'Date::Manip::Date') {
    50          
1086 54         69 $start = $start2;
1087             } elsif (! ref($start2)) {
1088 682         1517 $start = $self->new_date();
1089 682         1762 $start->parse($start2);
1090             } else {
1091 0         0 return ('Invalid start argument');
1092             }
1093 736 50       1840 return ('Start invalid') if ($start->err());
1094             } elsif (defined $$self{'data'}{'start'}) {
1095 369         579 $start = $$self{'data'}{'start'};
1096 369 50       676 return ('Start invalid') if ($start->err());
1097             }
1098              
1099 1286 100       2589 if (defined $end2) {
    100          
1100 736 100       1727 if (ref($end2) eq 'Date::Manip::Date') {
    50          
1101 54         66 $end = $end2;
1102             } elsif (! ref($end2)) {
1103 682         1510 $end = $self->new_date();
1104 682         1492 $end->parse($end2);
1105             } else {
1106 0         0 return ('Invalid end argument');
1107             }
1108 736 50       1889 return ('End invalid') if ($end->err());
1109             } elsif (defined $$self{'data'}{'end'}) {
1110 369         538 $end = $$self{'data'}{'end'};
1111 369 50       645 return ('End invalid') if ($end->err());
1112             }
1113              
1114 1286 100       2958 if (defined $$self{'data'}{'base'}) {
1115 227         347 my $base = $$self{'data'}{'base'};
1116 227 50       436 return ('Base invalid') if ($base->err());
1117             }
1118              
1119             # *Y:M:W:D:H:MN:S is complete.
1120              
1121 1286 100       2790 if ($$self{'data'}{'noint'}) {
1122 148 100       293 if ($$self{'data'}{'noint'} == 1) {
1123 137         275 my @dates = $self->_apply_rtime_mods();
1124 137         280 $$self{'data'}{'noint'} = 2;
1125              
1126 137         197 my $n = 0;
1127 137         183 foreach my $date (@dates) {
1128 230 50       373 next if (! defined $date);
1129 230         523 $$self{'data'}{'dates'}{$n++} = $date;
1130             }
1131              
1132 137 50       254 return (0,$start,$end) if ($n == 0);
1133              
1134 137 100 66     310 if (defined $start && defined $end) {
1135 5         12 my ($first,$last);
1136 5         18 for (my $i=0; $i<$n; $i++) {
1137 7         16 my $date = $$self{'data'}{'dates'}{$i};
1138 7 100 66     25 if ($start->cmp($date) <= 0 &&
1139             $end->cmp($date) >= 0) {
1140 4         7 $first = $i;
1141 4         27 last;
1142             }
1143             }
1144 5         18 for (my $i=$n-1; $i>=0; $i--) {
1145 8         19 my $date = $$self{'data'}{'dates'}{$i};
1146 8 100 100     20 if ($start->cmp($date) <= 0 &&
1147             $end->cmp($date) >= 0) {
1148 4         10 $last = $i;
1149 4         8 last;
1150             }
1151             }
1152              
1153 5         15 $$self{'data'}{'first'} = $first;
1154 5         17 $$self{'data'}{'last'} = $last;
1155             } else {
1156 132         180 $$self{'data'}{'first'} = 0;
1157 132         253 $$self{'data'}{'last'} = $n-1;
1158             }
1159             }
1160 148         361 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     7001 if ($start && $end) {
    100          
1167 1100 50       2678 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         3190 $self->_actual_base($start);
1175              
1176 1131 50       2418 if (defined $$self{'data'}{'BASE'}) {
1177 1131         1610 my $base = $$self{'data'}{'BASE'};
1178 1131 50       2535 return ('Base invalid') if ($base->err());
1179 1131         2972 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   1660 my($self,$start2) = @_;
1191              
1192             # Is the actual base date already defined?
1193              
1194 1131 100       2231 return if (defined $$self{'data'}{'BASE'});
1195              
1196             # Use the specified base date or start date.
1197              
1198 1011         1402 my $base = undef;
1199 1011 100       2132 if (defined $$self{'data'}{'base'}) {
    50          
    0          
1200 171         274 $base = $$self{'data'}{'base'};
1201             } elsif (defined $start2) {
1202 840         1288 $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         1610 my $dmt = $$self{'tz'};
1212 1011         1253 my $dmb = $$dmt{'base'};
1213 1011         2781 $dmt->_update_now(); # Update NOW
1214 1011         1218 my @int = @{ $$self{'data'}{'interval'} };
  1011         2335  
1215 1011         1254 my @rtime = @{ $$self{'data'}{'rtime'} };
  1011         2531  
1216 1011         2071 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1217 1011         1731 my ($y,$m,$d,$h,$mn,$s) = $base->value();
1218 1011         2405 my $BASE = $self->new_date();
1219 1011         1505 my $n = @int;
1220              
1221 1011 50       2441 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         2424 $BASE->set('date',[$y,1,1,0,0,0]);
1228              
1229             } elsif ($n == 2) {
1230             # Y:M*W:D:H:MN:S
1231 78         269 $BASE->set('date',[$y,$m,1,0,0,0]);
1232              
1233             } elsif ($n == 3) {
1234             # Y:M:W*D:H:MN:S
1235 19         94 my($yy,$w) = $dmb->week_of_year([$y,$m,$d,$h,$mn,$s]);
1236 19         47 my($ymd) = $dmb->week_of_year($yy,$w);
1237 19         72 $BASE->set('date',[@$ymd,0,0,0]);
1238              
1239             } elsif ($n == 4) {
1240             # Y:M:W:D*H:MN:S
1241 31         99 $BASE->set('date',[$y,$m,$d,0,0,0]);
1242              
1243             } elsif ($n == 5) {
1244             # Y:M:W:D:H*MN:S
1245 5         19 $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         42 $BASE->set('date',[$y,$m,$d,$h,$mn,$s]);
1254             }
1255              
1256 1011         3471 $$self{'data'}{'BASE'} = $BASE;
1257             }
1258              
1259             sub _rx {
1260 2986     2986   3806 my($self,$rx) = @_;
1261 2986         3232 my $dmt = $$self{'tz'};
1262 2986         3221 my $dmb = $$dmt{'base'};
1263              
1264             return $$dmb{'data'}{'rx'}{'recur'}{$rx}
1265 2986 100       7594 if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx});
1266              
1267 122 100 66     813 if ($rx eq 'std') {
    100 66        
    100          
    100          
    50          
1268              
1269 28         99 my $l = '[0-9]*';
1270 28         73 my $r = '[-,0-9]*';
1271 28         418 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         7904 $$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         240 my $num = '[+-]?\d+';
1286 28         112 my $range = "$num\-$num";
1287 28         58 my $val = "(?:$range|$num)";
1288 28         58 my $vals = "$val(?:,$val)*";
1289              
1290 28         2395 $$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/;
1291 28         795 $$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/;
1292 28         865 $$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/;
1293              
1294             } elsif ($rx eq 'each') {
1295              
1296 22         64 my $each = $$dmb{'data'}{'rx'}{'each'};
1297              
1298 22         933 my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i;
1299 22         106 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx;
1300              
1301             } elsif ($rx eq 'ignore') {
1302              
1303 22         74 my $of = $$dmb{'data'}{'rx'}{'of'};
1304 22         62 my $on = $$dmb{'data'}{'rx'}{'on'};
1305              
1306 22         1257 my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i;
1307 22         128 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx;
1308              
1309             } elsif ($rx eq 'every') {
1310              
1311 22         60 my $month = $$dmb{'data'}{'rx'}{'fields'}[2];
1312 22         50 my $week = $$dmb{'data'}{'rx'}{'fields'}[3];
1313 22         53 my $day = $$dmb{'data'}{'rx'}{'fields'}[4];
1314              
1315 22         60 my $last = $$dmb{'data'}{'rx'}{'last'};
1316 22         62 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
1317 22         86 my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
1318 22         88 my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0];
1319              
1320 22         61 my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
1321 22         61 my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
1322 22         58 my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1323 22         48 my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0];
1324              
1325 22         41 my $beg = '(?:^|\s+)';
1326 22         288 my $end = '(?:\s*$)';
1327              
1328 22         82 $month = "$beg(?$month)"; # months
1329 22         3533 $week = "$beg(?$week)"; # weeks
1330 22         53 $day = "$beg(?$day)"; # days
1331              
1332 22         44 $last = "$beg(?$last)"; # last
1333 22         83 $nth = "$beg(?$nth)"; # 1st,2nd,...
1334 22         49 $nth_wom = "$beg(?$nth_wom)"; # 1st - 5th
1335 22         63 $nth_dom = "$beg(?$nth_dom)"; # 1st - 31st
1336 22         55 my $n = "$beg(?\\d+)"; # 1,2,...
1337              
1338 22         59 my $dow = "$beg(?:(?$day_name)|(?$day_abb))"; # Sun|Sunday
1339 22         241 my $mmm = "$beg(?:(?$mon_name)|(?$mon_abb))"; # Jan|January
1340              
1341 22         57 my $y = "(?:$beg(?:(?\\d\\d\\d\\d)|(?\\d\\d)))?";
1342              
1343 22         378 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         38095 $freqrx = qr/^(?:$freqrx)\s*$/i;
1372 22         805 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx;
1373             }
1374              
1375 122         546 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   5623 my($self,$date) = @_;
1393 4050         5129 my $dmt = $$self{'tz'};
1394 4050         4914 my $dmb = $$dmt{'base'};
1395 4050         4096 my @int = @{ $$self{'data'}{'interval'} };
  4050         8640  
1396 4050         4487 my @rtime = @{ $$self{'data'}{'rtime'} };
  4050         8399  
1397 4050         4866 my $n = @int;
1398              
1399 4050         7340 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1400 4050         8312 my $m_empty = $self->_field_empty($mf);
1401 4050         5662 my $w_empty = $self->_field_empty($wf);
1402 4050         5366 my $d_empty = $self->_field_empty($df);
1403 4050         6335 my ($err,$y,$m,$d,$h,$mn,$s,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n);
1404 4050 100       11981 ($y,$m,$d,$h,$mn,$s) = $date->value() if (defined $date);
1405 4050         5430 my(@date);
1406              
1407 4050 100       6774 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       4556 if (@int == 0) {
1414 137         308 ($err,@y) = $self->_rtime_values('y',$yf);
1415 137 50       240 return () if ($err);
1416             } else {
1417 3144         4172 @y = ($y);
1418             }
1419              
1420 3281 100 100     13324 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       3774 $mf = [1] if ($m_empty);
1434 2480 100       3439 $df = [1] if ($d_empty);
1435              
1436 2480         4888 ($err,@m) = $self->_rtime_values('m',$mf);
1437 2480 50       3758 return () if ($err);
1438              
1439 2480         2852 foreach my $y (@y) {
1440 2496         2659 foreach my $m (@m) {
1441 2549         3675 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1442 2549 50       3639 return () if ($err);
1443 2549         3035 foreach my $d (@d) {
1444 2429         6596 push(@date,[$y,$m,$d,0,0,0]);
1445             }
1446             }
1447             }
1448              
1449             } elsif ($m_empty) {
1450              
1451 328 100       609 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         233 foreach my $y (@y) {
1458 171         346 ($err,@doy) = $self->_rtime_values('day_of_year',$df,$y);
1459 171 50       266 return () if ($err);
1460 171         211 foreach my $doy (@doy) {
1461 137         157 my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) };
  137         269  
1462 137         365 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         76 foreach my $y (@y) {
1473 49         100 ($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y);
1474 49 50       86 return () if ($err);
1475 49         58 foreach my $woy (@woy) {
1476 51         54 my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) };
  51         104  
1477 51         141 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         283 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1488 128 50       258 return () if ($err);
1489 128         168 foreach my $y (@y) {
1490 164         179 foreach my $dow (@dow) {
1491 164         223 ($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow);
1492 164 50       310 return () if ($err);
1493 164         230 foreach my $n (@n) {
1494 82         201 my $ymd = $dmb->nth_day_of_week($y,$n,$dow);
1495 82         149 my($yy,$mm,$dd) = @$ymd;
1496 82         236 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         1052 ($err,@m) = $self->_rtime_values('m',$mf);
1512 473 50       733 return () if ($err);
1513              
1514 473 100       764 if ($d_empty) {
1515 76         262 @dow = ($dmb->_config('firstday'));
1516             } else {
1517 397         629 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1518 397 50       609 return () if ($err);
1519             }
1520              
1521 473         552 foreach my $y (@y) {
1522 477         605 foreach my $m (@m) {
1523 639         682 foreach my $dow (@dow) {
1524 639         991 ($err,@n) = $self->_rtime_values('dow_of_month',
1525             $wf,$y,$m,$dow);
1526 639 50       867 return () if ($err);
1527 639         786 foreach my $n (@n) {
1528 629         1409 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1529 629         931 my($yy,$mm,$dd) = @$ymd;
1530 629         1728 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       735 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       445 $df = [1] if ($d_empty);
1551              
1552 261         568 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1553 261 50       441 return () if ($err);
1554 261         304 foreach my $d (@d) {
1555 271         612 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       304 if ($d_empty) {
1566 51         149 @dow = ($dmb->_config('firstday'));
1567             } else {
1568 136         281 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1569 136 50       241 return () if ($err);
1570             }
1571              
1572 187         247 foreach my $dow (@dow) {
1573 187         306 ($err,@n) = $self->_rtime_values('dow_of_month',
1574             $wf,$y,$m,$dow);
1575 187 50       295 return () if ($err);
1576 187         248 foreach my $n (@n) {
1577 237         448 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1578 237         304 my($yy,$mm,$dd) = @$ymd;
1579 237         600 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         315 my $fdow = $dmb->_config('firstday');
1600 100 100       168 if ($d_empty) {
1601 35         97 @dow = ($fdow);
1602             } else {
1603 65         152 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1604 65 50       94 return () if ($err);
1605             }
1606              
1607 100         122 my($mm,$dd);
1608 100         304 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]);
1609 100         147 ($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) };
  100         195  
1610              
1611 100         137 foreach my $dow (@dow) {
1612 112 50       193 $dow += 7 if ($dow < $fdow);
1613 112         116 my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) };
  112         257  
1614 112         294 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         272 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         97 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         111 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       6288 if ($n <= 4 ) {
1656 3962         6056 ($err,@h) = $self->_rtime_values('h',$hf);
1657 3962 50       5762 return () if ($err);
1658 3962         8138 $self->_field_add_values(\@date,3,@h);
1659             }
1660              
1661             # Do minutes
1662 4050 100       6591 if ($n <= 5) {
1663 3995         5205 ($err,@mn) = $self->_rtime_values('mn',$mnf);
1664 3995 50       5557 return () if ($err);
1665 3995         5456 $self->_field_add_values(\@date,4,@mn);
1666             }
1667              
1668             # Do seconds
1669 4050 100       5902 if ($n <= 6) {
1670 3995         5415 ($err,@s) = $self->_rtime_values('s',$sf);
1671 3995 50       5595 return () if ($err);
1672 3995         5466 $self->_field_add_values(\@date,5,@s);
1673             }
1674              
1675             # Sort the dates... just to be sure.
1676              
1677 4050 100       10070 @date = sort { $dmb->cmp($a,$b) } @date if (@date);
  507         1082  
1678              
1679             #
1680             # Apply modifiers
1681             #
1682              
1683 4050         4169 my @flags = @{ $$self{'data'}{'flags'} };
  4050         8111  
1684 4050 100       5755 if (@flags) {
1685 2156         5619 my $obj = $self->new_date();
1686              
1687 2156         2703 my @keep;
1688 2156         2828 foreach my $date (@date) {
1689 2192         3985 my ($y,$m,$d,$h,$mn,$s) = @$date;
1690              
1691 2192         2333 my $keep = 1;
1692              
1693             MODIFIER:
1694 2192         2410 foreach my $flag (@flags) {
1695 2343         2508 my(@wd,$today);
1696              
1697 2343 100 100     20948 if ($flag =~ /^([pn])([dt])([1-7])$/) {
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1698 56         153 my($forw,$today,$dow) = ($1,$2,$3);
1699 56 100       91 $forw = ($forw eq 'p' ? 0 : 1);
1700 56 100       76 $today = ($today eq 'd' ? 0 : 1);
1701             ($y,$m,$d,$h,$mn,$s) =
1702 56         57 @{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) };
  56         177  
1703              
1704             } elsif ($flag =~ /^([fb])([dw])(\d+)$/) {
1705 427         1475 my($prev,$business,$n) = ($1,$2,$3);
1706 427 100       754 $prev = ($prev eq 'b' ? 1 : 0);
1707 427 100       683 $business = ($business eq 'w' ? 1 : 0);
1708              
1709 427 100       631 if ($business) {
1710             ($y,$m,$d,$h,$mn,$s) =
1711 18         20 @{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) };
  18         91  
1712             } else {
1713 409         424 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) };
  409         1298  
1714             }
1715              
1716             } elsif ($flag eq 'ibd' ||
1717             $flag eq 'nbd') {
1718 243         743 my $bd = $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0);
1719              
1720 243 100 100     1107 if ( ($flag eq 'ibd' && ! $bd) ||
      100        
      100        
1721             ($flag eq 'nbd' && $bd) ) {
1722 113         119 $keep = 0;
1723 113         471 last MODIFIER;
1724             }
1725              
1726             } elsif ($flag =~ /^([in])w([1-7])$/) {
1727 99         333 my($is,$dow) = ($1,$2);
1728 99 50       208 $is = ($is eq 'i' ? 1 : 0);
1729 99         311 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1730 99 100 66     448 if ( ($is && $dow != $currdow) ||
      33        
      66        
1731             (! $is && $dow == $currdow) ) {
1732 85         106 $keep = 0;
1733 85         165 last MODIFIER;
1734             }
1735              
1736             } elsif ($flag =~ /^wd([1-7])$/) {
1737 9         25 my $dow = $1; # Dow wanted
1738 9         30 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1739 9 100       24 if ($dow != $currdow) {
1740 7         22 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]); # What week is this
1741 7         18 my $tmp = $dmb->week_of_year($yy,$ww); # First day of week
1742 7         12 ($y,$m,$d) = @$tmp;
1743 7         12 $currdow = $dmb->_config('firstday');
1744 7 50       19 if ($dow > $currdow) {
    0          
1745 7         26 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow);
1746 7         20 ($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       554 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1755             ($y,$m,$d,$h,$mn,$s) =
1756 78         91 @{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) };
  78         401  
1757             }
1758              
1759             } elsif ($flag eq 'pwd') {
1760 10 100       33 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1761             ($y,$m,$d,$h,$mn,$s) =
1762 5         10 @{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) };
  5         19  
1763             }
1764              
1765             } elsif ($flag eq 'easter') {
1766 21         44 ($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     2042 if ($flag eq 'cwd' || $flag eq 'dwd') {
    100          
    50          
1775 608 50       1201 if ($dmb->_config('tomorrowfirst')) {
1776 608         2403 @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         29 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1783 9         13 $today = 0;
1784              
1785             } elsif ($flag eq 'cwp') {
1786 9         46 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1787 9         13 $today = 0;
1788             }
1789              
1790 626         800 while (1) {
1791 739         911 my(@d,$off);
1792              
1793             # Test in the first direction
1794              
1795 739         803 @d = @{ $wd[0] };
  739         2058  
1796 739         900 $off = $wd[1];
1797 739         735 @d = @{ $dmb->calc_date_days(\@d,$off) };
  739         1922  
1798              
1799 739 100       1687 if ($obj->__is_business_day(\@d,0)) {
1800 396         745 ($y,$m,$d,$h,$mn,$s) = @d;
1801 396         1302 last;
1802             }
1803              
1804 343         737 $wd[0] = [@d];
1805              
1806             # Test in the other direction
1807              
1808 343         461 @d = @{ $wd[2] };
  343         668  
1809 343         429 $off = $wd[3];
1810 343         377 @d = @{ $dmb->calc_date_days(\@d,$off) };
  343         644  
1811              
1812 343 100       764 if ($obj->__is_business_day(\@d,0)) {
1813 230         411 ($y,$m,$d,$h,$mn,$s) = @d;
1814 230         817 last;
1815             }
1816              
1817 113         295 $wd[2] = [@d];
1818             }
1819              
1820             }
1821             }
1822              
1823 2192 100       3463 if ($keep) {
1824 1994         4631 push(@keep,[$y,$m,$d,$h,$mn,$s]);
1825             }
1826             }
1827 2156         10571 @date = @keep;
1828             }
1829              
1830             #
1831             # Convert the dates to objects.
1832             #
1833              
1834 4050         4564 my(@ret);
1835              
1836 4050         4715 foreach my $date (@date) {
1837 4039         7517 my @d = @$date;
1838              
1839 4039         8739 my $obj = $self->new_date();
1840 4039         11644 $obj->set('date',\@d);
1841 4039 100       10200 if ($obj->err()) {
1842 1         5 push(@ret,undef);
1843             } else {
1844 4038         7287 push(@ret,$obj);
1845             }
1846             }
1847              
1848 4050         18860 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   10561 my($self,$n) = @_;
1856 7768 100       14591 return if (exists $$self{'data'}{'idate'}{$n});
1857 3913         5087 my $base = $$self{'data'}{'BASE'};
1858 3913         4112 my $date;
1859              
1860             # Get the interval date.
1861              
1862 3913 100       5487 if ($n == 0) {
1863 999         1124 $date = $base;
1864              
1865             } else {
1866 2914         9324 my @delta = $$self{'data'}{'delta'}->value;
1867 2914         4042 my $absn = abs($n);
1868 2914         4941 @delta = map { $absn*$_ } @delta;
  20398         24027  
1869 2914         7081 my $delta = $self->new_delta;
1870 2914         9677 $delta->set('delta',[@delta]);
1871 2914 100       11447 $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       8798 if ($$self{'data'}{'slow'}) {
1878              
1879 24 100       53 if ($n > 0) {
    100          
1880 14         45 $self->_nth_interval($n-1);
1881             } elsif ($n < 0) {
1882 5         16 $self->_nth_interval($n+1);
1883             }
1884             }
1885              
1886             # Get the list of events associated with this interval date.
1887              
1888 3913         9058 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         4936 my($n0,$n1);
1896 3913 100       7709 if ($$self{'data'}{'slow'}) {
1897              
1898 24 100       67 if (! @date) {
    100          
    100          
1899 4         7 $n0 = undef;
1900 4         6 $n1 = undef;
1901              
1902             } elsif ($n == 0) {
1903 4         9 $n0 = 0;
1904 4         7 $n1 = $#date;
1905              
1906             } elsif ($n > 0) {
1907 11         30 foreach (my $i = $n-1; $i >= 0; $i--) {
1908 14 100       54 next if (! defined $$self{'data'}{'idate'}{$i}[2]);
1909 10         16 $n0 = $$self{'data'}{'idate'}{$i}[2] + 1;
1910 10         17 last;
1911             }
1912 11 100       18 $n0 = 0 if (! defined $n0);
1913 11         16 $n1 = $n0 + $#date;
1914              
1915             } else {
1916 5         15 foreach (my $i = $n+1; $i <= 0; $i++) {
1917 5 100       14 next if (! defined $$self{'data'}{'idate'}{$i}[1]);
1918 4         6 $n1 = $$self{'data'}{'idate'}{$i}[1] - 1;
1919 4         6 last;
1920             }
1921 5 100       9 $n1 = -1 if (! defined $n1);
1922 5         20 $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         5044 $n0 = $n * $$self{'data'}{'ev_per_d'};
1936 3889         5357 $n1 = $n0 + $$self{'data'}{'ev_per_d'} - 1;
1937             }
1938              
1939             # Store the dates.
1940              
1941 3913         7168 for (my $i=0; $i<=$#date; $i++) {
1942 3809         12157 $$self{'data'}{'dates'}{$n0+$i} = $date[$i];
1943             }
1944              
1945             # Store the idate.
1946              
1947 3913 100       6192 if ($$self{'data'}{'slow'}) {
1948 24         83 $$self{'data'}{'idate'}{$n} = [$date,$n0,$n1];
1949             } else {
1950 3889         8876 $$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   3402 my($self,$op) = @_;
1959              
1960 2351 100       5682 return $$self{'data'}{$op} if (defined $$self{'data'}{$op});
1961              
1962 1152         1697 my $start = $$self{'data'}{'start'};
1963 1152         1561 my $end = $$self{'data'}{'end'};
1964 1152         1508 my $unmod = $$self{'data'}{'unmod_range'};
1965 1152         1419 my $dmt = $$self{'tz'};
1966 1152         1457 my $dmb = $$dmt{'base'};
1967 1152         2689 my $maxatt = $dmb->_config('maxrecurattempts');
1968              
1969 1152 100       2701 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         6 my($i,$first,$last);
1974              
1975             # Find the first date in the interval
1976              
1977 3         6 $i = 0;
1978 3         7 while (1) {
1979 7 100       46 last if (! exists $$self{'data'}{'dates'}{$i});
1980 5         10 my $date = $$self{'data'}{'dates'}{$i};
1981 5 100       13 if ($date->cmp($start) == -1) {
    50          
1982             # date < start : move to the next one
1983 4         7 $i++;
1984 4         8 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         2 $first = $i;
1991 1         2 last;
1992             }
1993             }
1994              
1995             # If we found one, find the last one
1996              
1997 3 100       10 if (defined($first)) {
1998 1         1 $i = $first;
1999 1         3 $last = $i;
2000 1         1 while (1) {
2001 4 50       274 last if (! exists $$self{'data'}{'dates'}{$i});
2002 4         6 my $date = $$self{'data'}{'dates'}{$i};
2003 4 100       7 if ($date->cmp($end) == 1) {
2004             # date > end : we're done
2005 1         2 last;
2006             } else {
2007             # date <= end : this might be the last one
2008 3         3 $last = $i;
2009 3         4 $i++;
2010 3         4 next;
2011             }
2012             }
2013             }
2014              
2015 3         7 $$self{'data'}{'first'} = $first;
2016 3         7 $$self{'data'}{'last'} = $last;
2017 3         11 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         1762 my($first_int,$last_int,$first,$last);
2043              
2044 1149 100       2208 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         6 $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         6 my $n = 0;
2075 4         6 while (1) {
2076 9 50       20 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         21 $self->_nth_interval($first_int);
2082 9         19 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2083 9 100       15 if (defined $ptr) {
2084 8         12 my $date = $$self{'data'}{'dates'}{$ptr};
2085 8 50       15 if (defined($date)) {
2086 8         9 $n = 0;
2087 8 100       23 last if ($date->cmp($start) < 0);
2088             } else {
2089 0         0 $n++;
2090             }
2091             } else {
2092 1         2 $n++;
2093             }
2094 5         7 $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       12 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         10 my $n = 0;
2123 4         5 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         26 $self->_nth_interval($first_int);
2130 11         16 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2131 11 100       20 if (defined $ptr) {
2132 10         13 my $date = $$self{'data'}{'dates'}{$ptr};
2133 10 50       15 if (defined($date)) {
2134 10         10 $n = 0;
2135 10 100       22 last if ($date->cmp($start) >= 0);
2136             } else {
2137 0         0 $n++;
2138             }
2139             } else {
2140 1         2 $n++;
2141             }
2142 7         10 $first_int++;
2143             }
2144              
2145 4         16 foreach my $i ($$self{'data'}{'idate'}{$first_int}[1] ..
2146             $$self{'data'}{'idate'}{$first_int}[2]) {
2147 4         9 my $date = $$self{'data'}{'dates'}{$i};
2148 4 50 33     14 if (defined $date && $date->cmp($start) >= 0) {
2149 4         6 $first = $i;
2150 4         10 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         6 $last_int = $first_int;
2159              
2160 4 50       8 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         6 my $n = 0;
2191 4         4 while (1) {
2192 14 50       85 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         27 $self->_nth_interval($last_int);
2198 14         26 my $ptr = $$self{'data'}{'idate'}{$last_int}[1];
2199 14 100       22 if (defined $ptr) {
2200 12         17 my $date = $$self{'data'}{'dates'}{$ptr};
2201 12 50       14 if (defined($date)) {
2202 12         11 $n = 0;
2203 12 100       31 last if ($date->cmp($end) > 0);
2204             } else {
2205 0         0 $n++;
2206             }
2207             } else {
2208 2         3 $n++;
2209             }
2210 10         14 $last_int++;
2211             }
2212 4         7 $last_int--;
2213              
2214 4         6 $last = undef;
2215 4         7 my $i = $first;
2216 4         5 while (1) {
2217 17 50       31 last if (! exists $$self{'data'}{'dates'}{$i});
2218 17         19 my $date = $$self{'data'}{'dates'}{$i};
2219 17 50       28 next if (! defined $date);
2220 17 100       22 last if ($date->cmp($end) > 0);
2221 13         15 $last = $i;
2222 13         14 $i++;
2223             }
2224             }
2225              
2226 4 50 33     20 return undef if (! defined $last ||
2227             $last < $first);
2228 4         9 $$self{'data'}{'first'} = $first;
2229 4         7 $$self{'data'}{'last'} = $last;
2230 4         13 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         1651 my $base = $$self{'data'}{'BASE'};
2245 1145         1494 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       4615 my $len = ($delta ? $delta->printf('%sys') : 0);
2248              
2249 1145 100       2229 my $targ = ($op eq 'first' ? $start : $end);
2250 1145         3179 my $diff = $base->calc($targ);
2251 1145         3043 my $tot = $diff->printf('%sys');
2252 1145 50       2957 my $nn = ($len ? int($tot/$len) : 1);
2253 1145         2583 my $ev = $$self{'data'}{'ev_per_d'};
2254              
2255             # Move backwards until we're completely before start
2256              
2257 1145         1462 $first_int = $nn;
2258 1145 100       1977 if ($unmod) {
2259 739         895 my $n = 0;
2260 739         913 while (1) {
2261 1492 50       2453 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         3838 $self->_nth_interval($first_int);
2267 1492         2639 my $date = $$self{'data'}{'idate'}{$first_int};
2268 1492 50       2089 if (defined($date)) {
2269 1492         1482 $n = 0;
2270 1492 100       3170 last if ($date->cmp($start) < 0);
2271             } else {
2272 0         0 $n++;
2273             }
2274 753         1113 $first_int--;
2275             }
2276              
2277             } else {
2278 406         499 my $n = 0;
2279             LOOP:
2280 406         471 while (1) {
2281 885 100       1508 if ($n > $maxatt) {
2282 1         5 $$self{'err'} =
2283             "[_locate_n] Unable to find an interval in $maxatt attempts";
2284 1         19 return;
2285             }
2286 884         2087 $self->_nth_interval($first_int);
2287 884         2191 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2288 1012 100       1866 if (exists $$self{'data'}{'dates'}{$i}) {
2289 816         1141 my $date = $$self{'data'}{'dates'}{$i};
2290 816 50       1153 if (defined($date)) {
2291 816         894 $n = 0;
2292 816 100       1878 last LOOP if ($date->cmp($start) < 0);
2293             } else {
2294 0         0 $n++;
2295             }
2296             } else {
2297 196         322 $n++;
2298             }
2299             }
2300 479         627 $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       2226 if ($unmod) {
2308 739         929 my $n = 0;
2309 739         785 while (1) {
2310 1478 50       2365 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         3090 $self->_nth_interval($first_int);
2316 1478         1992 my $date = $$self{'data'}{'idate'}{$first_int};
2317 1478 50       1955 if (defined($date)) {
2318 1478         1468 $n = 0;
2319 1478 100       2328 last if ($date->cmp($start) >= 0);
2320             } else {
2321 0         0 $n++;
2322             }
2323 739         1072 $first_int++;
2324             }
2325              
2326             } else {
2327 405         563 my $n = 0;
2328             LOOP:
2329 405         455 while (1) {
2330 839 50       1440 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         1762 $self->_nth_interval($first_int);
2336 839         1841 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2337 963 100       1601 if (exists $$self{'data'}{'dates'}{$i}) {
2338 872         1189 my $date = $$self{'data'}{'dates'}{$i};
2339 872 50       1206 if (defined($date)) {
2340 872         903 $n = 0;
2341 872 100       1386 last LOOP if ($date->cmp($start) >= 0);
2342             } else {
2343 0         0 $n++;
2344             }
2345             } else {
2346 91         141 $n++;
2347             }
2348             }
2349 434         581 $first_int++;
2350             }
2351             }
2352 1144         1608 $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         1602 $last_int = $first_int;
2358              
2359 1144 100       2154 if ($unmod) {
2360 739         889 my $n = 0;
2361 739         816 while (1) {
2362 1478 50       2217 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         2601 $self->_nth_interval($last_int);
2368 1478         2481 my $date = $$self{'data'}{'idate'}{$last_int};
2369 1478 50       2054 if (defined($date)) {
2370 1478         1510 $n = 0;
2371 1478 100       2692 last if ($date->cmp($end) > 0);
2372             } else {
2373 0         0 $n++;
2374             }
2375 739         1173 $last_int++;
2376             }
2377 739         1275 $last_int--;
2378              
2379             } else {
2380 405         511 my $n = 0;
2381             LOOP:
2382 405         464 while (1) {
2383 1462 50       2233 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         8944 $self->_nth_interval($last_int);
2389 1462         3432 for (my $i=($last_int+1)*$ev - 1; $i >= $last_int*$ev; $i--) {
2390 1701 100       3478 next if (! exists $$self{'data'}{'dates'}{$i});
2391 1544         2015 my $date = $$self{'data'}{'dates'}{$i};
2392 1544 50       2034 if (defined($date)) {
2393 1544         1640 $n = 0;
2394 1544 100       3029 last LOOP if ($date->cmp($end) >= 0);
2395             } else {
2396 0         0 $n++;
2397             }
2398             }
2399 1057         1222 $last_int++;
2400             }
2401             }
2402              
2403 1144         1976 $last = ($last_int+1)*$ev - 1;
2404              
2405             # Now get the actual first/last dates
2406              
2407 1144 100       2199 if ($unmod) {
2408 739         886 while (1) {
2409             last if (exists $$self{'data'}{'dates'}{$first} &&
2410 739 100 66     3261 defined $$self{'data'}{'dates'}{$first});
2411 112         136 $first++;
2412 112 50       1072 return undef if ($first > $last);
2413             }
2414              
2415 627         720 while (1) {
2416             last if (exists $$self{'data'}{'dates'}{$last} &&
2417 627 50 33     2196 defined $$self{'data'}{'dates'}{$last});
2418 0         0 $last--;
2419             }
2420              
2421             } else {
2422 405         505 while (1) {
2423             last if (exists $$self{'data'}{'dates'}{$first} &&
2424             defined $$self{'data'}{'dates'}{$first} &&
2425 407 100 33     2413 $$self{'data'}{'dates'}{$first}->cmp($start) >= 0);
      66        
2426 2         4 $first++;
2427 2 50       7 return undef if ($first > $last);
2428             }
2429              
2430 405         525 while (1) {
2431             last if (exists $$self{'data'}{'dates'}{$last} &&
2432             defined $$self{'data'}{'dates'}{$last} &&
2433 954 100 66     3837 $$self{'data'}{'dates'}{$last}->cmp($end) <= 0);
      100        
2434 549         660 $last--;
2435             }
2436             }
2437              
2438 1032 100 66     7646 return undef if (! defined $last ||
2439             $last < $first);
2440 934         1659 $$self{'data'}{'first'} = $first;
2441 934         1461 $$self{'data'}{'last'} = $last;
2442 934         10053 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   31 my($self,$y) = @_;
2450              
2451 21         49 my($c) = $y/100;
2452 21         27 my($g) = $y % 19;
2453 21         25 my($k) = ($c-17)/25;
2454 21         40 my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30;
2455 21         34 $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11));
2456 21         26 my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
2457 21         22 my($l) = $i-$j;
2458 21         39 my($m) = 3 + ($l+40)/44;
2459 21         28 my($d) = $l + 28 - 31*($m/4);
2460 21         42 return ($m,$d);
2461             }
2462              
2463             # This returns 1 if a field is empty.
2464             #
2465             sub _field_empty {
2466 12150     12150   13951 my($self,$val) = @_;
2467              
2468 12150 100       13729 if (ref($val)) {
2469 10839         13245 my @tmp = @$val;
2470 10839 100 100     38765 return 1 if ($#tmp == -1 ||
      100        
      66        
2471             ($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0]));
2472 7289         10173 return 0;
2473              
2474             } else {
2475 1311         1748 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   26821 my($self,$type,$val,@args) = @_;
2500 19788         20023 my $dmt = $$self{'tz'};
2501 19788         19435 my $dmb = $$dmt{'base'};
2502              
2503 19788 100       43871 if ($type eq 'h') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
2504 3962         5229 @args = (0,0,23,23);
2505              
2506             } elsif ($type eq 'mn') {
2507 3995         5082 @args = (0,0,59,59);
2508              
2509             } elsif ($type eq 's') {
2510 3995         4984 @args = (0,0,59,59);
2511              
2512             } elsif ($type eq 'y') {
2513 137         434 my $curry = $dmt->_now('y',1);
2514 137         223 foreach my $y (@$val) {
2515 213 100 66     599 $y = $curry if (! ref($y) && $y==0);
2516             }
2517              
2518 137         236 @args = (0,1,9999,9999);
2519              
2520             } elsif ($type eq 'm') {
2521 2953         4186 @args = (0,1,12,12);
2522              
2523             } elsif ($type eq 'week_of_year') {
2524 49         69 my($y) = @args;
2525 49         136 my $wiy = $dmb->weeks_in_year($y);
2526 49         104 @args = (1,1,$wiy,53);
2527              
2528             } elsif ($type eq 'dow_of_year') {
2529 164         249 my($y,$dow) = @args;
2530              
2531             # Get the 1st occurrence of $dow
2532 164         173 my $d0 = 1;
2533 164         458 my $dow0 = $dmb->day_of_week([$y,1,$d0]);
2534 164 100       401 if ($dow > $dow0) {
    100          
2535 15         19 $d0 += ($dow-$dow0);
2536             } elsif ($dow < $dow0) {
2537 119         142 $d0 += 7-($dow0-$dow);
2538             }
2539              
2540             # Get the last occurrence of $dow
2541 164         162 my $d1 = 31;
2542 164         284 my $dow1 = $dmb->day_of_week([$y,12,$d1]);
2543 164 100       296 if ($dow1 > $dow) {
    100          
2544 121         139 $d1 -= ($dow1-$dow);
2545             } elsif ($dow1 < $dow) {
2546 15         20 $d1 -= 7-($dow-$dow1);
2547             }
2548              
2549             # Find out the number of occurrenced of $dow
2550 164         372 my $doy1 = $dmb->day_of_year([$y,12,$d1]);
2551 164         274 my $n = ($doy1 - $d0)/7 + 1;
2552              
2553             # Get the list of @w
2554 164         305 @args = (1,1,$n,53);
2555              
2556             } elsif ($type eq 'dow_of_month') {
2557 826         1231 my($y,$m,$dow) = @args;
2558              
2559             # Get the 1st occurrence of $dow in the month
2560 826         928 my $d0 = 1;
2561 826         2383 my $dow0 = $dmb->day_of_week([$y,$m,$d0]);
2562 826 100       1848 if ($dow > $dow0) {
    100          
2563 185         267 $d0 += ($dow-$dow0);
2564             } elsif ($dow < $dow0) {
2565 504         667 $d0 += 7-($dow0-$dow);
2566             }
2567              
2568             # Get the last occurrence of $dow
2569 826         1590 my $d1 = $dmb->days_in_month($y,$m);
2570 826         1687 my $dow1 = $dmb->day_of_week([$y,$m,$d1]);
2571 826 100       1473 if ($dow1 > $dow) {
    100          
2572 526         610 $d1 -= ($dow1-$dow);
2573             } elsif ($dow1 < $dow) {
2574 180         249 $d1 -= 7-($dow-$dow1);
2575             }
2576              
2577             # Find out the number of occurrenced of $dow
2578 826         1019 my $n = ($d1 - $d0)/7 + 1;
2579              
2580             # Get the list of @w
2581 826         1479 @args = (1,1,$n,5);
2582              
2583             } elsif ($type eq 'day_of_year') {
2584 171         208 my($y) = @args;
2585 171         375 my $diy = $dmb->days_in_year($y);
2586 171         277 @args = (1,1,$diy,366);
2587              
2588             } elsif ($type eq 'day_of_month') {
2589 2810         3801 my($y,$m) = @args;
2590 2810         6465 my $dim = $dmb->days_in_month($y,$m);
2591 2810         4720 @args = (1,1,$dim,31);
2592              
2593             } elsif ($type eq 'day_of_week') {
2594 726         1060 @args = (0,1,7,7);
2595             }
2596              
2597 19788         25789 my($err,@vals) = $self->__rtime_values($val,@args);
2598 19788 50       25942 if ($err) {
2599 0         0 $$self{'err'} = "[dates] $err [$type]";
2600 0         0 return (1);
2601             }
2602 19788         31576 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   25835 my($self,$vals,$allowneg,$min,$max,$absmax) = @_;
2622 19788         17746 my(@ret);
2623              
2624 19788         21984 foreach my $val (@$vals) {
2625              
2626 20337 100       22494 if (ref($val)) {
2627 24         36 my($val1,$val2) = @$val;
2628              
2629 24 50       53 if ($allowneg) {
2630 24 0 33     112 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     119 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     110 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       34 $val1 = $max + $val1 + 1 if ($val1 < 0); # day -10
2652 24 50       43 $val2 = $max + $val2 + 1 if ($val2 < 0);
2653              
2654 24 50       32 $val1 = $min if ($val1 < $min); # day -31 in a 30 day month
2655 24 50       38 $val2 = $max if ($val2 > $max);
2656              
2657 24 100       43 next if ($val1 > $val2);
2658              
2659 20         42 push(@ret,$val1..$val2);
2660              
2661             } else {
2662              
2663 20313 100       22450 if ($allowneg) {
2664 4193 50 33     11851 return ('Value outside range')
      66        
2665             if ($val >= 0 && ($val < $min || $val > $absmax));
2666 4193 50 33     7041 return ('Negative value outside range')
      66        
2667             if ($val <= 0 && ($val < -$absmax || $val > -$min));
2668             } else {
2669 16120 50 33     31988 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         17949 my $ret;
2677 20313 100       22051 if ($val < 0 ) {
2678 401         505 $ret = $max + $val + 1;
2679             } else {
2680 19912         18399 $ret = $val;
2681             }
2682              
2683 20313 100 100     37758 next if ($ret > $max || $ret < $min);
2684 19925         24342 push(@ret,$ret);
2685             }
2686             }
2687              
2688 19788         36980 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   16130 my($self,$datesref,$n,@val) = @_;
2697              
2698 11952         13392 my @dates = @$datesref;
2699 11952         10567 my @tmp;
2700              
2701 11952         12127 foreach my $date (@dates) {
2702 12397         16802 my @d = @$date;
2703 12397         12352 foreach my $val (@val) {
2704 12465         14000 $d[$n] = $val;
2705 12465         25517 push(@tmp,[@d]);
2706             }
2707             }
2708              
2709 11952         21869 @$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: