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-2022 Sullivan Beck. All rights reserved.
3             # This program is free software; you can redistribute it and/or modify
4             # it under the same terms as Perl itself.
5              
6             ########################################################################
7             # Any routine that starts with an underscore (_) is NOT intended for
8             # public use. They are for internal use in the the Date::Manip
9             # modules and are subject to change without warning or notice.
10             #
11             # ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
12             ########################################################################
13              
14 168     168   1219 use Date::Manip::Obj;
  168         692  
  168         8324  
15             @ISA = ('Date::Manip::Obj');
16              
17             require 5.010000;
18 168     168   971 use warnings;
  168         366  
  168         5872  
19 168     168   1046 use strict;
  168         406  
  168         4500  
20 168     168   925 use integer;
  168         370  
  168         6053  
21 168     168   4898 use utf8;
  168         397  
  168         943  
22 168     168   4435 use IO::File;
  168         419  
  168         28071  
23             #use re 'debug';
24              
25 168     168   1184 use Date::Manip::Base;
  168         353  
  168         4217  
26 168     168   953 use Date::Manip::TZ;
  168         472  
  168         2365528  
27              
28             our $VERSION;
29             $VERSION='6.90';
30 168     168   2526 END { undef $VERSION; }
31              
32             ########################################################################
33             # BASE METHODS
34             ########################################################################
35              
36             sub is_recur {
37 1     1 1 116 return 1;
38             }
39              
40             # Call this every time a new recur is put in to make sure everything is
41             # correctly initialized.
42             #
43             sub _init {
44 1718     1718   2998 my($self) = @_;
45 1718         3782 my $dmt = $$self{'tz'};
46 1718         2782 my $dmb = $$dmt{'base'};
47              
48 1718         2890 $$self{'err'} = '';
49              
50 1718         3031 $$self{'data'}{'freq'} = ''; # The frequency
51 1718         3416 $$self{'data'}{'flags'} = []; # Modifiers
52 1718         3848 $$self{'data'}{'base'} = undef; # The specified base date
53 1718         2710 $$self{'data'}{'BASE'} = undef; # The actual base date
54 1718         3511 $$self{'data'}{'start'} = undef; # Start and end date
55 1718         3320 $$self{'data'}{'end'} = undef;
56 1718         2644 $$self{'data'}{'unmod_range'} = 0; # If this is 1, the start/end range
57             # refer to the unmodified dates, not the
58             # final dates.
59              
60 1718         3373 $$self{'data'}{'interval'} = []; # (Y, M, ...)
61 1718         3805 $$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
62             # [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
63             # ... )
64 1718         2717 $$self{'data'}{'slow'} = 0; # 1 if a range of the form 2--2 is
65             # included.
66 1718         2769 $$self{'data'}{'ev_per_d'} = 0; # The number of events per interval date.
67 1718         4486 $$self{'data'}{'delta'} = undef; # The offset based on the interval.
68 1718         2803 $$self{'data'}{'noint'} = 1; # 0 if an interval is present
69             # 1 if no interval is present and dates
70             # not done
71             # 2 if no interval is present and dates
72             # done
73              
74 1718         7201 $$self{'data'}{'idate'} = {}; # Non-slow:
75             # { N => Nth interval date }
76             # Slow:
77             # { N => [Nth interval date,X,Y] }
78             # [X,Y] are the first/last event indices
79             # generated by this interval date.
80 1718         6399 $$self{'data'}{'dates'} = {}; # { N => Nth recurring event }
81             # N is relative to the base date and is
82             # not affected by start/end
83 1718         3267 $$self{'data'}{'curr'} = undef; # Iterator pointer
84 1718         2699 $$self{'data'}{'first'} = undef; # N : the first date in a range
85 1718         2649 $$self{'data'}{'last'} = undef; # N : the last date in a range
86              
87             # Get the default start/end dates
88              
89 1718         5447 my $range = $dmb->_config('recurrange');
90              
91 1718 50       3904 if ($range eq 'none') {
    0          
    0          
    0          
    0          
    0          
92 1718         2746 $$self{'data'}{'start'} = undef;
93 1718         3277 $$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   3119 my($self,$keep) = @_;
153              
154 1603 100       3357 if (! $keep) {
155 1097         3165 $$self{'data'}{'base'} = undef;
156 1097         2102 $$self{'data'}{'BASE'} = undef;
157 1097         13106 $$self{'data'}{'idate'} = {};
158 1097         8588 $$self{'data'}{'dates'} = {};
159             }
160 1603         2809 $$self{'data'}{'curr'} = undef;
161 1603         2599 $$self{'data'}{'first'} = undef;
162 1603         3163 $$self{'data'}{'last'} = undef;
163             }
164              
165             sub _init_args {
166 2     2   4 my($self) = @_;
167              
168 2         5 my @args = @{ $$self{'args'} };
  2         5  
169 2         8 $self->parse(@args);
170             }
171              
172             ########################################################################
173             # METHODS
174             ########################################################################
175              
176             sub parse {
177 487     487 1 376472 my($self,$string,@args) = @_;
178 487         1620 $self->_init();
179              
180             # Test if $string = FREQ
181              
182 487         1504 my $err = $self->frequency($string);
183 487 100       1270 if (! $err) {
184 364         677 $string = '';
185             }
186              
187             # Test if $string = "FREQ*..." and FREQ contains an '*'.
188              
189 487 100       1119 if ($err) {
190 123         584 $self->err(1);
191              
192 123         864 $string =~ s/\s*\*\s*/\*/g;
193              
194 123 50       601 if ($string =~ /^([^*]*\*[^*]*)\*/) {
195             # Everything up to the 2nd '*'
196 123         370 my $freq = $1;
197 123         365 $err = $self->frequency($freq);
198 123 50       327 if (! $err) {
199 123         2117 $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       1258 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       1034 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         1282 my @string = split(/\*/,$string);
231              
232 487 100       1173 if (@string) {
233 123         250 my $tmp = shift(@string);
234 123 100       481 $err = $self->modifiers($tmp) if ($tmp);
235 123 50       361 return 1 if ($err);
236             }
237              
238 487 100       1066 if (@args) {
239 266         486 my $tmp = $args[0];
240 266 100 66     1020 if ($tmp && ! ref($tmp)) {
241 207         761 $err = $self->modifiers($tmp);
242 207 100       589 shift(@args) if (! $err);
243             }
244             }
245              
246             # Handle BASE
247              
248 487 100       1133 if (@string) {
249 25         93 my $tmp = shift(@string);
250 25 100 66     167 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
251 25 50       80 return 1 if ($err);
252             }
253 487 100       1073 if (@args) {
254 265         469 my $tmp = shift(@args);
255 265 100 66     1163 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
256 265 50       620 return 1 if ($err);
257             }
258              
259             # Handle START, END, UNMOD
260              
261 487 100       1091 if (@string) {
262 24         83 my($start) = shift(@string);
263 24         60 my($end) = shift(@string);
264 24         56 my($unmod) = shift(@string);
265              
266 24 50 33     230 $err = $self->start($start,$unmod) if (defined($start) && $start);
267 24 50       95 return 1 if ($err);
268              
269 24 50 33     225 $err = $self->end($end) if (defined($end) && $end);
270 24 50       115 return 1 if ($err);
271             }
272 487 100       1040 if (@args) {
273 265         546 my($start) = shift(@args);
274 265         510 my($end) = shift(@args);
275 265         445 my($unmod) = shift(@args);
276              
277 265 100 66     1339 $err = $self->start($start,$unmod) if (defined($start) && $start);
278 265 50       774 return 1 if ($err);
279              
280 265 100 66     1293 $err = $self->end($end) if (defined($end) && $end);
281 265 50       818 return 1 if ($err);
282             }
283              
284             # Remaining arguments are invalid.
285              
286 487 50       1146 if (@string) {
287 0         0 $$self{'err'} = "[parse] String contains invalid elements";
288 0         0 return 1;
289             }
290 487 50       1066 if (@args) {
291 0         0 $$self{'err'} = "[parse] Unknown arguments";
292 0         0 return 1;
293             }
294              
295 487         1351 return 0;
296             }
297              
298             sub frequency {
299 942     942 1 370035 my($self,$string) = @_;
300 942 50       2357 return $$self{'data'}{'freq'} if (! defined $string);
301              
302 942         2359 $self->_init();
303 942         1605 my (@int,@rtime);
304              
305             PARSE: {
306              
307             # Standard frequency notation
308              
309 942         1478 my $stdrx = $self->_rx('std');
  942         2618  
310 942 100       10219 if ($string =~ $stdrx) {
311 782         8242 my($l,$r) = @+{qw(l r)};
312              
313 782 50       2922 if (defined($l)) {
314 782         1977 $l =~ s/^\s*:/0:/;
315 782         1712 $l =~ s/:\s*$/:0/;
316 782         1341 $l =~ s/::/:0:/g;
317              
318 782         2519 @int = split(/:/,$l);
319             }
320              
321 782 50       1776 if (defined($r)) {
322 782         1986 $r =~ s/^\s*:/0:/;
323 782         2458 $r =~ s/:\s*$/:0/;
324 782         1448 $r =~ s/::/:0:/g;
325              
326 782         2186 @rtime = split(/:/,$r);
327             }
328              
329 782         1840 last PARSE;
330             }
331              
332             # Other frequency strings
333              
334             # Strip out some words to ignore
335              
336 160         486 my $ignrx = $self->_rx('ignore');
337 160         1440 $string =~ s/$ignrx/ /g;
338              
339 160         426 my $eachrx = $self->_rx('each');
340 160         287 my $each = 0;
341 160 100       1160 if ($string =~ s/$eachrx/ /g) {
342 28         55 $each = 1;
343             }
344              
345 160         1099 $string =~ s/\s*$//;
346              
347 160 50       433 if (! $string) {
348 0         0 $$self{'err'} = "[frequency] Invalid frequency string";
349 0         0 return 1;
350             }
351              
352 160         472 my $err = $self->_parse_lang($string);
353 160 100       439 if ($err) {
354 128         279 $$self{'err'} = "[frequency] Invalid frequency string";
355 128         336 return 1;
356             }
357 32         79 return 0;
358             }
359              
360             # If the interval consists only of zeros, the last entry is changed
361             # to 1.
362              
363 782 100       1953 if (@int) {
364 552         1113 for my $i (@int) {
365 1078         2001 $i += 0;
366             }
367              
368             TEST_INT: {
369 552         789 for my $i (@int) {
  552         979  
370 787 100       1875 last TEST_INT if ($i);
371             }
372 75         159 $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     4756 while (@int &&
      100        
      100        
382             ($#int == 1 || $#int == 2) &&
383             ($int[$#int] == 0)) {
384 101         185 pop(@int);
385 101         527 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         2474 my @ftype = ('y','m','w','d','h','mn','s');
405 782         1875 my @vtype = ('' ,'' ,'' ,'' ,'' ,'' ,'');
406              
407 782         2024 my ($y,$m,$w,$d,$h,$mn,$s) = (@int,@rtime);
408              
409 782 100       1875 if (@rtime == 7) {
410 230         419 $vtype[0] = 'y';
411             }
412              
413 782 100       1826 if (@rtime >= 6) {
414 547 100       1135 if ($m) {
415 371         625 $vtype[1] = 'moy';
416             } else {
417 176         296 $vtype[1] = 'zero';
418             }
419             }
420              
421 782 100       1648 if (@rtime >= 5) {
422 685 100       1316 if ($w) {
423 329 100       687 if ($m) {
424 226         385 $vtype[2] = 'wom';
425             } else {
426 103         173 $vtype[2] = 'woy';
427             }
428             } else {
429 356         662 $vtype[2] = 'zero';
430             }
431             }
432              
433 782 100       1727 if (@rtime >= 4) {
434 727 100       1374 if ($d) {
435 528 100       1203 if ($w) {
    100          
436 226         407 $vtype[3] = 'dow';
437             } elsif ($m) {
438 247         433 $vtype[3] = 'dom';
439             } else {
440 55         110 $vtype[3] = 'doy';
441             }
442             } else {
443 199         315 $vtype[3] = 'zero';
444             }
445             }
446              
447 782 100       1690 if (@rtime >= 3) {
448 766         1196 $vtype[4] = 'time';
449             }
450 782 100       1705 if (@rtime >= 2) {
451 771         1203 $vtype[5] = 'time';
452             }
453 782 100       1602 if (@rtime) {
454 771         1077 $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         1879 my $rfieldrx = $self->_rx('rfield');
466 782         1635 my $rrangerx = $self->_rx('rrange');
467              
468 782         1254 my $i = -1;
469 782         1548 foreach my $f (@int,@rtime) {
470 4772         6175 $i++;
471 4772         6775 my $vtype = $vtype[$i];
472 4772         6002 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       8332 next if (! $vtype);
480              
481 3795 100 100     20196 if ($f && $f !~ $rfieldrx) {
482 1         5 $$self{'err'} = "[frequency] Invalid rtime string";
483 1         6 return 1;
484             }
485              
486 3794         8225 my @rfield = split(/,/,$f);
487 3794         4987 my @val;
488              
489 3794         5478 foreach my $vals (@rfield) {
490 3858 100       14702 if ($vals =~ $rrangerx) {
491 73         374 my ($num1,$num2) = ($1+0,$2+0);
492              
493 73         236 my $err = $self->_frequency_values($num1,$type,$vtype);
494 73 100       184 return $err if ($err);
495              
496 72         169 $err = $self->_frequency_values($num2,$type,$vtype);
497 72 50       207 return $err if ($err);
498              
499 72 100 100     343 if ( ($num1 > 0 && $num2 > 0) ||
      66        
      100        
500             ($num1 < 0 && $num2 < 0) ) {
501 66 100       155 if ($num1 > $num2) {
502 2         7 $$self{'err'} = "[frequency] Invalid rtime range string";
503 2         13 return 1;
504             }
505 64         243 push(@val,$num1..$num2);
506             } else {
507 6         26 push(@val,[$num1,$num2]);
508             }
509              
510             } else {
511 3785         6341 $vals += 0;
512              
513 3785         7304 my $err = $self->_frequency_values($vals,$type,$vtype);
514 3785 100       7345 return $err if ($err);
515              
516 3609         6635 push(@val,$vals);
517             }
518             }
519              
520 3615         9004 $f = [ @val ];
521             }
522              
523             # Store it
524              
525 602         1617 $$self{'data'}{'interval'} = [ @int ];
526 602         1580 $$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         1562 my $freq = join(':',@int);
532 602         957 my $slow = 0;
533 602         855 my $n = 1;
534 602 100       1328 if (@rtime) {
535 591         1044 $freq .= '*';
536 591         794 my (@tmp);
537              
538 591         1080 foreach my $rtime (@rtime) {
539 3418         4037 my @t2;
540 3418         4712 foreach my $tmp (@$rtime) {
541 3694 100       5368 if (ref($tmp)) {
542 6         14 my($a,$b) = @$tmp;
543 6         30 push(@t2,"$a-$b");
544 6         13 $slow = 1;
545             } else {
546 3688         5841 push(@t2,$tmp);
547             }
548             }
549 3418         5687 my $tmp = join(',',@t2);
550 3418         5133 push(@tmp,$tmp);
551 3418         4286 my $nn = @t2;
552 3418         5667 $n *= $nn;
553             }
554 591         1916 $freq .= join(':',@tmp);
555             }
556 602         1308 $$self{'data'}{'freq'} = $freq;
557 602         1029 $$self{'data'}{'slow'} = $slow;
558 602 100       1456 $$self{'data'}{'ev_per_d'} = $n if (! $slow);
559              
560 602 100       1238 if (@int) {
561 436         739 $$self{'data'}{'noint'} = 0;
562              
563 436         1011 while (@int < 7) {
564 2256         3995 push(@int,0);
565             }
566 436         1823 my $delta = $self->new_delta();
567 436         2422 $delta->set('delta',[@int]);
568 436         1235 $$self{'data'}{'delta'} = $delta;
569              
570             } else {
571 166         275 $$self{'data'}{'noint'} = 1;
572             }
573              
574 602         2859 return 0;
575             }
576              
577             sub _frequency_values {
578 3930     3930   7273 my($self,$num,$type,$vtype) = @_;
579 3930         4839 my $err;
580              
581 3930 100       11378 if ($type eq 'y') {
    100          
    100          
    100          
    100          
582 248 50       540 if ($vtype eq 'y') {
583 248 100 100     942 if ($num < 0 || $num > 9999) {
584 16         42 $$self{'err'} = "[frequency] Year must be in the range 1-9999";
585 16         34 return 1;
586             }
587             }
588              
589             } elsif ($type eq 'm') {
590 572 100       1205 if ($vtype eq 'moy') {
591 404 100 100     1529 if ($num < 1 || $num > 12) {
592 34         74 $$self{'err'} = "[frequency] Month of year must be 1-12";
593 34         71 return 1;
594             }
595             }
596              
597             } elsif ($type eq 'w') {
598 670 100       2049 if ($vtype eq 'woy') {
    100          
599 103 100 66     624 if ($num == 0 || $num > 53 || $num < -53) {
      100        
600 22         43 $$self{'err'} = "[frequency] Week of year must be 1-53 or -1 to -53";
601 22         47 return 1;
602             }
603              
604             } elsif ($vtype eq 'wom') {
605 235 100 66     1332 if ($num == 0 || $num > 5 || $num < -5) {
      100        
606 31         53 $$self{'err'} = "[frequency] Week of month must be 1-5 or -1 to -5";
607 31         61 return 1;
608             }
609              
610             }
611              
612             } elsif ($type eq 'd') {
613 635 100       1925 if ($vtype eq 'dow') {
    100          
    100          
614 190 100 100     897 if ($num < 1 || $num > 7) {
615 36         67 $$self{'err'} = "[frequency] Day of week must be 1-7";
616 36         80 return 1;
617             }
618              
619             } elsif ($vtype eq 'dom') {
620 245 100 66     1614 if ($num == 0 || $num > 31 || $num < -31) {
      100        
621 20         38 $$self{'err'} = "[frequency] Day of month must be 1-31 or -1 to -31";
622 20         44 return 1;
623             }
624              
625             } elsif ($vtype eq 'doy') {
626 55 100 66     362 if ($num == 0 || $num > 366 || $num < -366) {
      100        
627 14         28 $$self{'err'} = "[frequency] Day of year must be 1-366 or -1 to -366";
628 14         29 return 1;
629             }
630             }
631              
632             } elsif ($type eq 'h') {
633 614 50       1439 if ($vtype eq 'time') {
634 614 100 66     2287 if ($num < 0 || $num > 23) {
635 1         9 $$self{'err'} = "[frequency] Hour must be 0-23";
636 1         8 return 1;
637             }
638             }
639              
640             } else {
641 1191 50       2436 if ($vtype eq 'time') {
642 1191 100 66     3964 if ($num < 0 || $num > 59) {
643 3         7 $$self{'err'} = "[frequency] Minute/second must be 0-59";
644 3         7 return 1;
645             }
646             }
647             }
648              
649 3753         6904 return 0;
650             }
651              
652             sub _parse_lang {
653 160     160   370 my($self,$string) = @_;
654 160         294 my $dmt = $$self{'tz'};
655 160         263 my $dmb = $$dmt{'base'};
656              
657             # Test the regular expression
658              
659 160         387 my $rx = $self->_rx('every');
660              
661 160 100       3010 return 1 if ($string !~ $rx);
662             my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) =
663 32         774 @+{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         135 my $dow;
668 32 100 66     170 if (defined($day_name) || defined($day_abb)) {
669 16 50       44 if (defined($day_name)) {
670 16         62 $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         52 my $mmm;
677 32 100 66     130 if (defined($mon_name) || defined($mon_abb)) {
678 8 50       25 if (defined($mon_name)) {
679 8         26 $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       86 if (defined($nth)) {
686 14         62 $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
687             }
688              
689             # Get the frequencies
690              
691 32         50 my($freq);
692 32 100       100 if (defined($dow)) {
    50          
693 16 100       35 if (defined($mmm)) {
694 8 100       24 if (defined($last)) {
    100          
695             # last DoW in MMM [YY]
696 2         12 $freq = "1*$mmm:-1:$dow:0:0:0";
697              
698             } elsif (defined($nth)) {
699             # Nth DoW in MMM [YY]
700 4         20 $freq = "1*$mmm:$nth:$dow:0:0:0";
701              
702             } else {
703             # every DoW in MMM [YY]
704 2         9 $freq = "1*$mmm:1-5:$dow:0:0:0";
705             }
706              
707             } else {
708 8 100       28 if (defined($last)) {
    100          
709             # last DoW in every month [in YY]
710 2         12 $freq = "0:1*-1:$dow:0:0:0";
711              
712             } elsif (defined($nth)) {
713             # Nth DoW in every month [in YY]
714 4         23 $freq = "0:1*$nth:$dow:0:0:0";
715              
716             } else {
717             # every DoW in every month [in YY]
718 2         7 $freq = "0:1*1-5:$dow:0:0:0";
719             }
720             }
721              
722             } elsif (defined($day)) {
723 16 100       42 if (defined($month)) {
724 8 100       22 if (defined($nth)) {
    100          
725             # Nth day of every month [YY]
726 4         18 $freq = "0:1*0:$nth:0:0:0";
727              
728             } elsif (defined($last)) {
729             # last day of every month [YY]
730 2         5 $freq = "0:1*0:-1:0:0:0";
731              
732             } else {
733             # every day of every month [YY]
734 2         5 $freq = "0:0:0:1*0:0:0";
735             }
736              
737             } else {
738 8 100       22 if (defined($nth)) {
    100          
739             # every Nth day [YY]
740 2         8 $freq = "0:0:0:$nth*0:0:0";
741              
742             } elsif (defined($n)) {
743             # every N days [YY]
744 4         19 $freq = "0:0:0:$n*0:0:0";
745              
746             } else {
747             # every day [YY]
748 2         5 $freq = "0:0:0:1*0:0:0";
749             }
750             }
751             }
752              
753             # Get the range (if YY is included)
754              
755 32 100       72 if (defined($y)) {
756 18         85 $y = $dmt->_fix_year($y);
757 18         48 my $start = "${y}010100:00:00";
758 18         41 my $end = "${y}123123:59:59";
759              
760 18         110 return $self->parse($freq,undef,$start,$end);
761             }
762              
763 14         41 return $self->frequency($freq)
764             }
765              
766             sub _date {
767 679     679   1301 my($self,$op,$date_or_string) = @_;
768              
769             # Make sure the argument is a date
770              
771 679 50       1791 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         2063 my $date = $self->new_date();
780 679         2062 my $err = $date->parse($date_or_string);
781 679 50       1448 if ($err) {
782 0         0 $$self{'err'} = "[$op] Invalid date string";
783 0         0 return 1;
784             }
785 679         1669 $$self{'data'}{$op} = $date;
786             }
787              
788 679         1477 return 0;
789             }
790              
791             sub start {
792 1019     1019 1 2932 my($self,$start,$unmod) = @_;
793 1019 100       4393 return $$self{'data'}{'start'} if (! defined $start);
794              
795 253         768 $self->_init_dates(1);
796 253         477 $$self{'data'}{'unmod_range'} = $unmod;
797 253         728 $self->_date('start',$start);
798             }
799              
800             sub end {
801 337     337 1 1275 my($self,$end) = @_;
802 337 100       1251 return $$self{'data'}{'end'} if (! defined $end);
803              
804 253         718 $self->_init_dates(1);
805 253         683 $self->_date('end',$end);
806             }
807              
808             sub basedate {
809 173     173 1 2015 my($self,$base) = @_;
810 173 50       409 return ($$self{'data'}{'base'},$$self{'data'}{'BASE'}) if (! defined $base);
811              
812 173         511 $self->_init_dates();
813 173         534 $self->_date('base',$base);
814             }
815              
816             sub modifiers {
817 309     309 1 808 my($self,@flags) = @_;
818 309 50       747 return @{ $$self{'data'}{'flags'} } if (! @flags);
  0         0  
819              
820 309         609 my $dmt = $$self{'tz'};
821 309         579 my $dmb = $$dmt{'base'};
822 309 50       767 if (@flags == 1) {
823 309         1006 @flags = split(/,/,lc($flags[0]));
824             }
825              
826             # Add these flags to the list
827              
828 309 50 33     1421 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         718 foreach my $flag (@flags) {
837 322 100       1696 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         486 $$self{'err'} = "[modifiers] Invalid modifier: $flag";
839 151         451 return 1;
840             }
841              
842 158         482 $$self{'data'}{'flags'} = [ @flags ];
843 158         513 $self->_init_dates();
844              
845 158         336 return 0;
846             }
847              
848             sub nth {
849 2097     2097 1 7301 my($self,$n) = @_;
850 2097 100       4136 $n = 0 if (! $n);
851             return ($$self{'data'}{'dates'}{$n},0)
852 2097 100       6590 if (exists $$self{'data'}{'dates'}{$n});
853              
854 86         214 my ($err) = $self->_error();
855 86 50       209 return (undef,$err) if ($err);
856              
857             return ($$self{'data'}{'dates'}{$n},0)
858 86 100       223 if (exists $$self{'data'}{'dates'}{$n});
859              
860             # If there is no interval, then we've found every date that
861             # can be found.
862 84 100       205 if ($$self{'data'}{'noint'}) {
863 4         9 return (undef,0);
864             }
865              
866 80 100       197 if ($$self{'data'}{'slow'}) {
867 2         4 my $nn = 0;
868 2         4 while (1) {
869 4         11 $self->_nth_interval($nn);
870             return ($$self{'data'}{'dates'}{$n},0)
871 4 100       25 if (exists $$self{'data'}{'dates'}{$n});
872 2 50       22 if ($n >= 0) {
873 2         5 $nn++;
874             } else {
875 0         0 $nn--;
876             }
877             }
878              
879             } else {
880 78         119 my $nn;
881 78 100       164 if ($n >= 0) {
882 74         136 $nn = int($n/$$self{'data'}{'ev_per_d'});
883             } else {
884 4         10 $nn = int(($n+1)/$$self{'data'}{'ev_per_d'}) -1;
885             }
886 78         211 $self->_nth_interval($nn);
887 78         217 return ($$self{'data'}{'dates'}{$n},0);
888             }
889             }
890              
891             sub next {
892 8     8 1 1023 my($self) = @_;
893              
894 8         22 my ($err) = $self->_error();
895 8 50       21 return (undef,$err) if ($err);
896              
897             # If curr is not set, we have to get it.
898              
899 8 100       24 if (! defined $$self{'data'}{'curr'}) {
900              
901             CURR:
902 5         18 while (1) {
903              
904             # If no interval then
905             # return base date
906              
907 5 100       19 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     22 if (defined $$self{'data'}{'start'} &&
916             defined $$self{'data'}{'end'}) {
917              
918 2         9 my $n = $self->_locate_n('first');
919 2 100 66     18 return (undef,'Not found') if ($$self{'err'} || ! defined($n));
920 1         6 $$self{'data'}{'curr'} = $n-1;
921              
922             } else {
923 2         4 $$self{'data'}{'curr'} = -1;
924             }
925 3         6 last CURR;
926             }
927             }
928              
929             # With curr set, find the next defined one
930              
931 7         12 while (1) {
932 9         15 $$self{'data'}{'curr'}++;
933 9 100       20 if ($$self{'data'}{'noint'}) {
934             return (undef,0)
935 3 100       11 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
936             }
937 8         21 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
938 8 50       19 return (undef,$e) if ($e);
939 8 100       29 return ($d,0) if (defined $d);
940             }
941             }
942              
943             sub prev {
944 11     11 1 1388 my($self) = @_;
945              
946 11         26 my ($err) = $self->_error();
947 11 50       25 return (undef,$err) if ($err);
948              
949             # If curr is not set, we have to get it.
950              
951 11 100       27 if (! defined $$self{'data'}{'curr'}) {
952              
953             CURR:
954 5         8 while (1) {
955              
956             # If no interval then
957             # return last one
958              
959 5 100       16 if ($$self{'data'}{'noint'}) {
960 1         2 my @n = sort { $a <=> $b } keys %{ $$self{'data'}{'dates'} };
  1         5  
  1         6  
961 1         4 $$self{'data'}{'curr'} = pop(@n) + 1;
962 1         3 last CURR;
963             }
964              
965             # If a range is defined
966             # find last event in range and return it
967              
968 4 100 66     22 if (defined $$self{'data'}{'start'} &&
969             defined $$self{'data'}{'end'}) {
970              
971 2         9 my $n = $self->_locate_n('last');
972 2 100 66     16 return (undef,'Not found') if ($$self{'err'} || ! defined($n));
973 1         4 $$self{'data'}{'curr'} = $n+1;
974              
975             } else {
976 2         3 $$self{'data'}{'curr'} = 0;
977             }
978 3         7 last CURR;
979             }
980             }
981              
982             # With curr set, find the previous defined one
983              
984 10         15 while (1) {
985 11         17 $$self{'data'}{'curr'}--;
986 11 100       25 if ($$self{'data'}{'noint'}) {
987             return (undef,0)
988 6 100       19 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
989             }
990 9         26 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
991 9 50       29 return (undef,$e) if ($e);
992 9 100       33 return ($d,0) if (defined $d);
993             }
994             }
995              
996             sub dates {
997 1181     1181 1 3675 my($self,$start2,$end2,$unmod) = @_;
998 1181         3864 $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         1795 my $tmp_limits = 0;
1004 1181 100 100     3767 $tmp_limits = 1 if ($start2 || $end2);
1005 1181 100       2475 $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         1680 my $range_required;
1011 1181 100 100     3907 if (defined($start2) && defined($end2)) {
1012 735         1125 $range_required = 0;
1013             } else {
1014 446         706 $range_required = 1;
1015             }
1016              
1017 1181         1607 my($err);
1018 1181         3000 ($err,$start2,$end2) = $self->_error($range_required,$start2,$end2);
1019 1181 100       2637 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         2023 my ($old_start, $old_end, $old_first, $old_last, $old_unmod);
1025              
1026 1174 100       2393 if ($tmp_limits) {
1027 737         1417 $old_start = $$self{'data'}{'start'};
1028 737         1317 $old_end = $$self{'data'}{'end'};
1029 737         1219 $old_first = $$self{'data'}{'first'};
1030 737         1247 $old_last = $$self{'data'}{'last'};
1031 737         1262 $old_unmod = $$self{'data'}{'unmod_range'};
1032              
1033 737         1210 $$self{'data'}{'start'} = $start2;
1034 737         1195 $$self{'data'}{'end'} = $end2;
1035 737         1237 $$self{'data'}{'first'} = undef;
1036 737         1163 $$self{'data'}{'last'} = undef;
1037 737         1204 $$self{'data'}{'unmod_range'} = $unmod;
1038             }
1039              
1040             # Get all of the dates
1041              
1042 1174         1808 my($end,$first,$last,@dates);
1043              
1044 1174         3021 $first = $self->_locate_n('first');
1045 1174 100       3321 return () if ($$self{'err'});
1046 1173         3403 $last = $self->_locate_n('last');
1047 1173 50       3205 return () if ($$self{'err'});
1048              
1049 1173 100 66     4071 if (defined($first) && defined($last)) {
1050 1068         2758 for (my $n = $first; $n <= $last; $n++) {
1051 2050         4551 my($date,$err) = $self->nth($n);
1052 2050 100       6521 push(@dates,$date) if (defined $date);
1053             }
1054             }
1055              
1056             # Restore the original date range values.
1057              
1058 1173 100       2711 if ($tmp_limits) {
1059 737         1379 $$self{'data'}{'start'} = $old_start;
1060 737         1258 $$self{'data'}{'end'} = $old_end;
1061 737         1185 $$self{'data'}{'first'} = $old_first;
1062 737         1145 $$self{'data'}{'last'} = $old_last;
1063 737         1201 $$self{'data'}{'unmod_range'} = $old_unmod;
1064             }
1065              
1066 1173         7712 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   2697 my($self,$range_required,$start2,$end2) = @_;
1078              
1079 1286 50       2768 return ('Invalid recurrence') if ($self->err());
1080              
1081             # All dates entered must be valid.
1082              
1083 1286         2302 my($start,$end);
1084 1286 100       3294 if (defined $start2) {
    100          
1085 736 100       2018 if (ref($start2) eq 'Date::Manip::Date') {
    50          
1086 54         81 $start = $start2;
1087             } elsif (! ref($start2)) {
1088 682         1646 $start = $self->new_date();
1089 682         2242 $start->parse($start2);
1090             } else {
1091 0         0 return ('Invalid start argument');
1092             }
1093 736 50       2255 return ('Start invalid') if ($start->err());
1094             } elsif (defined $$self{'data'}{'start'}) {
1095 369         789 $start = $$self{'data'}{'start'};
1096 369 50       957 return ('Start invalid') if ($start->err());
1097             }
1098              
1099 1286 100       3550 if (defined $end2) {
    100          
1100 736 100       2110 if (ref($end2) eq 'Date::Manip::Date') {
    50          
1101 54         84 $end = $end2;
1102             } elsif (! ref($end2)) {
1103 682         1790 $end = $self->new_date();
1104 682         1995 $end->parse($end2);
1105             } else {
1106 0         0 return ('Invalid end argument');
1107             }
1108 736 50       2317 return ('End invalid') if ($end->err());
1109             } elsif (defined $$self{'data'}{'end'}) {
1110 369         739 $end = $$self{'data'}{'end'};
1111 369 50       846 return ('End invalid') if ($end->err());
1112             }
1113              
1114 1286 100       3520 if (defined $$self{'data'}{'base'}) {
1115 227         470 my $base = $$self{'data'}{'base'};
1116 227 50       505 return ('Base invalid') if ($base->err());
1117             }
1118              
1119             # *Y:M:W:D:H:MN:S is complete.
1120              
1121 1286 100       3237 if ($$self{'data'}{'noint'}) {
1122 148 100       362 if ($$self{'data'}{'noint'} == 1) {
1123 137         342 my @dates = $self->_apply_rtime_mods();
1124 137         293 $$self{'data'}{'noint'} = 2;
1125              
1126 137         217 my $n = 0;
1127 137         241 foreach my $date (@dates) {
1128 230 50       443 next if (! defined $date);
1129 230         604 $$self{'data'}{'dates'}{$n++} = $date;
1130             }
1131              
1132 137 50       317 return (0,$start,$end) if ($n == 0);
1133              
1134 137 100 66     397 if (defined $start && defined $end) {
1135 5         14 my ($first,$last);
1136 5         27 for (my $i=0; $i<$n; $i++) {
1137 7         19 my $date = $$self{'data'}{'dates'}{$i};
1138 7 100 66     26 if ($start->cmp($date) <= 0 &&
1139             $end->cmp($date) >= 0) {
1140 4         10 $first = $i;
1141 4         10 last;
1142             }
1143             }
1144 5         23 for (my $i=$n-1; $i>=0; $i--) {
1145 8         22 my $date = $$self{'data'}{'dates'}{$i};
1146 8 100 100     23 if ($start->cmp($date) <= 0 &&
1147             $end->cmp($date) >= 0) {
1148 4         13 $last = $i;
1149 4         24 last;
1150             }
1151             }
1152              
1153 5         16 $$self{'data'}{'first'} = $first;
1154 5         17 $$self{'data'}{'last'} = $last;
1155             } else {
1156 132         258 $$self{'data'}{'first'} = 0;
1157 132         287 $$self{'data'}{'last'} = $n-1;
1158             }
1159             }
1160 148         385 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     4015 if ($start && $end) {
    100          
1167 1100 50       3168 return ('Range invalid') if ($start->cmp($end) == 1);
1168             } elsif ($range_required) {
1169 7         20 return ('Incomplete recurrence');
1170             }
1171              
1172             # Check that the base date is available.
1173              
1174 1131         3912 $self->_actual_base($start);
1175              
1176 1131 50       3071 if (defined $$self{'data'}{'BASE'}) {
1177 1131         2076 my $base = $$self{'data'}{'BASE'};
1178 1131 50       3372 return ('Base invalid') if ($base->err());
1179 1131         3512 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   2211 my($self,$start2) = @_;
1191              
1192             # Is the actual base date already defined?
1193              
1194 1131 100       2972 return if (defined $$self{'data'}{'BASE'});
1195              
1196             # Use the specified base date or start date.
1197              
1198 1011         1770 my $base = undef;
1199 1011 100       2767 if (defined $$self{'data'}{'base'}) {
    50          
    0          
1200 171         315 $base = $$self{'data'}{'base'};
1201             } elsif (defined $start2) {
1202 840         1368 $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         1698 my $dmt = $$self{'tz'};
1212 1011         1609 my $dmb = $$dmt{'base'};
1213 1011         3263 $dmt->_update_now(); # Update NOW
1214 1011         1508 my @int = @{ $$self{'data'}{'interval'} };
  1011         3269  
1215 1011         1641 my @rtime = @{ $$self{'data'}{'rtime'} };
  1011         3395  
1216 1011         2454 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1217 1011         2520 my ($y,$m,$d,$h,$mn,$s) = $base->value();
1218 1011         2957 my $BASE = $self->new_date();
1219 1011         1901 my $n = @int;
1220              
1221 1011 50       3435 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         2956 $BASE->set('date',[$y,1,1,0,0,0]);
1228              
1229             } elsif ($n == 2) {
1230             # Y:M*W:D:H:MN:S
1231 78         328 $BASE->set('date',[$y,$m,1,0,0,0]);
1232              
1233             } elsif ($n == 3) {
1234             # Y:M:W*D:H:MN:S
1235 19         96 my($yy,$w) = $dmb->week_of_year([$y,$m,$d,$h,$mn,$s]);
1236 19         63 my($ymd) = $dmb->week_of_year($yy,$w);
1237 19         94 $BASE->set('date',[@$ymd,0,0,0]);
1238              
1239             } elsif ($n == 4) {
1240             # Y:M:W:D*H:MN:S
1241 31         122 $BASE->set('date',[$y,$m,$d,0,0,0]);
1242              
1243             } elsif ($n == 5) {
1244             # Y:M:W:D:H*MN:S
1245 5         24 $BASE->set('date',[$y,$m,$d,$h,0,0]);
1246              
1247             } elsif ($n == 6) {
1248             # Y:M:W:D:H:MN*S
1249 0         0 $BASE->set('date',[$y,$m,$d,$h,$mn,0]);
1250              
1251             } else {
1252             # Y:M:W:D:H:MN:S
1253 6         31 $BASE->set('date',[$y,$m,$d,$h,$mn,$s]);
1254             }
1255              
1256 1011         3710 $$self{'data'}{'BASE'} = $BASE;
1257             }
1258              
1259             sub _rx {
1260 2986     2986   5645 my($self,$rx) = @_;
1261 2986         4605 my $dmt = $$self{'tz'};
1262 2986         4111 my $dmb = $$dmt{'base'};
1263              
1264             return $$dmb{'data'}{'rx'}{'recur'}{$rx}
1265 2986 100       9353 if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx});
1266              
1267 122 100 66     1035 if ($rx eq 'std') {
    100 66        
    100          
    100          
    50          
1268              
1269 28         74 my $l = '[0-9]*';
1270 28         68 my $r = '[-,0-9]*';
1271 28         923 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         3702 $$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         106 my $num = '[+-]?\d+';
1286 28         123 my $range = "$num\-$num";
1287 28         318 my $val = "(?:$range|$num)";
1288 28         138 my $vals = "$val(?:,$val)*";
1289              
1290 28         1286 $$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/;
1291 28         576 $$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/;
1292 28         767 $$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/;
1293              
1294             } elsif ($rx eq 'each') {
1295              
1296 22         104 my $each = $$dmb{'data'}{'rx'}{'each'};
1297              
1298 22         713 my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i;
1299 22         164 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx;
1300              
1301             } elsif ($rx eq 'ignore') {
1302              
1303 22         96 my $of = $$dmb{'data'}{'rx'}{'of'};
1304 22         73 my $on = $$dmb{'data'}{'rx'}{'on'};
1305              
1306 22         773 my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i;
1307 22         131 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx;
1308              
1309             } elsif ($rx eq 'every') {
1310              
1311 22         94 my $month = $$dmb{'data'}{'rx'}{'fields'}[2];
1312 22         67 my $week = $$dmb{'data'}{'rx'}{'fields'}[3];
1313 22         94 my $day = $$dmb{'data'}{'rx'}{'fields'}[4];
1314              
1315 22         69 my $last = $$dmb{'data'}{'rx'}{'last'};
1316 22         71 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
1317 22         65 my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
1318 22         74 my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0];
1319              
1320 22         62 my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
1321 22         78 my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
1322 22         63 my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1323 22         66 my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0];
1324              
1325 22         48 my $beg = '(?:^|\s+)';
1326 22         54 my $end = '(?:\s*$)';
1327              
1328 22         96 $month = "$beg(?$month)"; # months
1329 22         72 $week = "$beg(?$week)"; # weeks
1330 22         75 $day = "$beg(?$day)"; # days
1331              
1332 22         79 $last = "$beg(?$last)"; # last
1333 22         135 $nth = "$beg(?$nth)"; # 1st,2nd,...
1334 22         87 $nth_wom = "$beg(?$nth_wom)"; # 1st - 5th
1335 22         105 $nth_dom = "$beg(?$nth_dom)"; # 1st - 31st
1336 22         72 my $n = "$beg(?\\d+)"; # 1,2,...
1337              
1338 22         121 my $dow = "$beg(?:(?$day_name)|(?$day_abb))"; # Sun|Sunday
1339 22         100 my $mmm = "$beg(?:(?$mon_name)|(?$mon_abb))"; # Jan|January
1340              
1341 22         89 my $y = "(?:$beg(?:(?\\d\\d\\d\\d)|(?\\d\\d)))?";
1342              
1343 22         702 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         40096 $freqrx = qr/^(?:$freqrx)\s*$/i;
1372 22         729 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx;
1373             }
1374              
1375 122         627 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   7483 my($self,$date) = @_;
1393 4050         6448 my $dmt = $$self{'tz'};
1394 4050         6187 my $dmb = $$dmt{'base'};
1395 4050         5510 my @int = @{ $$self{'data'}{'interval'} };
  4050         9001  
1396 4050         6152 my @rtime = @{ $$self{'data'}{'rtime'} };
  4050         9261  
1397 4050         6152 my $n = @int;
1398              
1399 4050         8364 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1400 4050         8533 my $m_empty = $self->_field_empty($mf);
1401 4050         7481 my $w_empty = $self->_field_empty($wf);
1402 4050         7647 my $d_empty = $self->_field_empty($df);
1403 4050         7458 my ($err,$y,$m,$d,$h,$mn,$s,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n);
1404 4050 100       13219 ($y,$m,$d,$h,$mn,$s) = $date->value() if (defined $date);
1405 4050         6733 my(@date);
1406              
1407 4050 100       8581 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       6383 if (@int == 0) {
1414 137         292 ($err,@y) = $self->_rtime_values('y',$yf);
1415 137 50       334 return () if ($err);
1416             } else {
1417 3144         5669 @y = ($y);
1418             }
1419              
1420 3281 100 100     17179 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       4901 $mf = [1] if ($m_empty);
1434 2480 100       4500 $df = [1] if ($d_empty);
1435              
1436 2480         5288 ($err,@m) = $self->_rtime_values('m',$mf);
1437 2480 50       4815 return () if ($err);
1438              
1439 2480         3923 foreach my $y (@y) {
1440 2496         3614 foreach my $m (@m) {
1441 2549         4835 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1442 2549 50       4929 return () if ($err);
1443 2549         3966 foreach my $d (@d) {
1444 2429         7704 push(@date,[$y,$m,$d,0,0,0]);
1445             }
1446             }
1447             }
1448              
1449             } elsif ($m_empty) {
1450              
1451 328 100       789 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         297 foreach my $y (@y) {
1458 171         377 ($err,@doy) = $self->_rtime_values('day_of_year',$df,$y);
1459 171 50       348 return () if ($err);
1460 171         308 foreach my $doy (@doy) {
1461 137         186 my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) };
  137         372  
1462 137         489 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         94 foreach my $y (@y) {
1473 49         119 ($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y);
1474 49 50       142 return () if ($err);
1475 49         94 foreach my $woy (@woy) {
1476 51         70 my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) };
  51         142  
1477 51         178 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         330 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1488 128 50       343 return () if ($err);
1489 128         220 foreach my $y (@y) {
1490 164         302 foreach my $dow (@dow) {
1491 164         351 ($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow);
1492 164 50       392 return () if ($err);
1493 164         349 foreach my $n (@n) {
1494 82         237 my $ymd = $dmb->nth_day_of_week($y,$n,$dow);
1495 82         176 my($yy,$mm,$dd) = @$ymd;
1496 82         307 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         1331 ($err,@m) = $self->_rtime_values('m',$mf);
1512 473 50       1208 return () if ($err);
1513              
1514 473 100       918 if ($d_empty) {
1515 76         254 @dow = ($dmb->_config('firstday'));
1516             } else {
1517 397         862 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1518 397 50       1031 return () if ($err);
1519             }
1520              
1521 473         1043 foreach my $y (@y) {
1522 477         799 foreach my $m (@m) {
1523 639         987 foreach my $dow (@dow) {
1524 639         1385 ($err,@n) = $self->_rtime_values('dow_of_month',
1525             $wf,$y,$m,$dow);
1526 639 50       1462 return () if ($err);
1527 639         1132 foreach my $n (@n) {
1528 629         1880 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1529 629         1362 my($yy,$mm,$dd) = @$ymd;
1530 629         2288 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       901 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       597 $df = [1] if ($d_empty);
1551              
1552 261         590 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1553 261 50       550 return () if ($err);
1554 261         424 foreach my $d (@d) {
1555 271         815 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       392 if ($d_empty) {
1566 51         152 @dow = ($dmb->_config('firstday'));
1567             } else {
1568 136         319 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1569 136 50       362 return () if ($err);
1570             }
1571              
1572 187         343 foreach my $dow (@dow) {
1573 187         396 ($err,@n) = $self->_rtime_values('dow_of_month',
1574             $wf,$y,$m,$dow);
1575 187 50       396 return () if ($err);
1576 187         315 foreach my $n (@n) {
1577 237         633 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1578 237         487 my($yy,$mm,$dd) = @$ymd;
1579 237         759 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         312 my $fdow = $dmb->_config('firstday');
1600 100 100       287 if ($d_empty) {
1601 35         75 @dow = ($fdow);
1602             } else {
1603 65         172 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1604 65 50       178 return () if ($err);
1605             }
1606              
1607 100         149 my($mm,$dd);
1608 100         345 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]);
1609 100         187 ($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) };
  100         220  
1610              
1611 100         228 foreach my $dow (@dow) {
1612 112 50       255 $dow += 7 if ($dow < $fdow);
1613 112         160 my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) };
  112         372  
1614 112         382 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         359 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         83 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         139 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       8695 if ($n <= 4 ) {
1656 3962         7846 ($err,@h) = $self->_rtime_values('h',$hf);
1657 3962 50       7379 return () if ($err);
1658 3962         9219 $self->_field_add_values(\@date,3,@h);
1659             }
1660              
1661             # Do minutes
1662 4050 100       8614 if ($n <= 5) {
1663 3995         7579 ($err,@mn) = $self->_rtime_values('mn',$mnf);
1664 3995 50       7993 return () if ($err);
1665 3995         9109 $self->_field_add_values(\@date,4,@mn);
1666             }
1667              
1668             # Do seconds
1669 4050 100       8214 if ($n <= 6) {
1670 3995         7404 ($err,@s) = $self->_rtime_values('s',$sf);
1671 3995 50       7534 return () if ($err);
1672 3995         7983 $self->_field_add_values(\@date,5,@s);
1673             }
1674              
1675             # Sort the dates... just to be sure.
1676              
1677 4050 100       12942 @date = sort { $dmb->cmp($a,$b) } @date if (@date);
  507         1338  
1678              
1679             #
1680             # Apply modifiers
1681             #
1682              
1683 4050         5838 my @flags = @{ $$self{'data'}{'flags'} };
  4050         9421  
1684 4050 100       8164 if (@flags) {
1685 2156         6419 my $obj = $self->new_date();
1686              
1687 2156         3318 my @keep;
1688 2156         3954 foreach my $date (@date) {
1689 2192         4977 my ($y,$m,$d,$h,$mn,$s) = @$date;
1690              
1691 2192         3211 my $keep = 1;
1692              
1693             MODIFIER:
1694 2192         3367 foreach my $flag (@flags) {
1695 2343         3502 my(@wd,$today);
1696              
1697 2343 100 100     23969 if ($flag =~ /^([pn])([dt])([1-7])$/) {
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1698 56         187 my($forw,$today,$dow) = ($1,$2,$3);
1699 56 100       138 $forw = ($forw eq 'p' ? 0 : 1);
1700 56 100       111 $today = ($today eq 'd' ? 0 : 1);
1701             ($y,$m,$d,$h,$mn,$s) =
1702 56         69 @{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) };
  56         207  
1703              
1704             } elsif ($flag =~ /^([fb])([dw])(\d+)$/) {
1705 427         1760 my($prev,$business,$n) = ($1,$2,$3);
1706 427 100       1125 $prev = ($prev eq 'b' ? 1 : 0);
1707 427 100       890 $business = ($business eq 'w' ? 1 : 0);
1708              
1709 427 100       816 if ($business) {
1710             ($y,$m,$d,$h,$mn,$s) =
1711 18         44 @{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) };
  18         98  
1712             } else {
1713 409         571 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) };
  409         1636  
1714             }
1715              
1716             } elsif ($flag eq 'ibd' ||
1717             $flag eq 'nbd') {
1718 243         966 my $bd = $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0);
1719              
1720 243 100 100     1482 if ( ($flag eq 'ibd' && ! $bd) ||
      100        
      100        
1721             ($flag eq 'nbd' && $bd) ) {
1722 113         174 $keep = 0;
1723 113         279 last MODIFIER;
1724             }
1725              
1726             } elsif ($flag =~ /^([in])w([1-7])$/) {
1727 99         379 my($is,$dow) = ($1,$2);
1728 99 50       215 $is = ($is eq 'i' ? 1 : 0);
1729 99         354 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1730 99 100 66     539 if ( ($is && $dow != $currdow) ||
      33        
      66        
1731             (! $is && $dow == $currdow) ) {
1732 85         129 $keep = 0;
1733 85         187 last MODIFIER;
1734             }
1735              
1736             } elsif ($flag =~ /^wd([1-7])$/) {
1737 9         29 my $dow = $1; # Dow wanted
1738 9         53 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1739 9 100       37 if ($dow != $currdow) {
1740 7         24 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]); # What week is this
1741 7         20 my $tmp = $dmb->week_of_year($yy,$ww); # First day of week
1742 7         15 ($y,$m,$d) = @$tmp;
1743 7         15 $currdow = $dmb->_config('firstday');
1744 7 50       16 if ($dow > $currdow) {
    0          
1745 7         23 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow);
1746 7         25 ($y,$m,$d) = @$tmp;
1747             } elsif ($dow < $currdow) {
1748 0         0 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow+7);
1749 0         0 ($y,$m,$d) = @$tmp;
1750             }
1751             }
1752              
1753             } elsif ($flag eq 'nwd') {
1754 166 100       669 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1755             ($y,$m,$d,$h,$mn,$s) =
1756 78         121 @{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) };
  78         352  
1757             }
1758              
1759             } elsif ($flag eq 'pwd') {
1760 10 100       47 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1761             ($y,$m,$d,$h,$mn,$s) =
1762 5         11 @{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) };
  5         23  
1763             }
1764              
1765             } elsif ($flag eq 'easter') {
1766 21         62 ($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     2815 if ($flag eq 'cwd' || $flag eq 'dwd') {
    100          
    50          
1775 608 50       1445 if ($dmb->_config('tomorrowfirst')) {
1776 608         3036 @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         41 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1783 9         18 $today = 0;
1784              
1785             } elsif ($flag eq 'cwp') {
1786 9         79 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1787 9         23 $today = 0;
1788             }
1789              
1790 626         1200 while (1) {
1791 739         1232 my(@d,$off);
1792              
1793             # Test in the first direction
1794              
1795 739         1077 @d = @{ $wd[0] };
  739         2224  
1796 739         1227 $off = $wd[1];
1797 739         1043 @d = @{ $dmb->calc_date_days(\@d,$off) };
  739         2248  
1798              
1799 739 100       2591 if ($obj->__is_business_day(\@d,0)) {
1800 396         1131 ($y,$m,$d,$h,$mn,$s) = @d;
1801 396         1599 last;
1802             }
1803              
1804 343         1116 $wd[0] = [@d];
1805              
1806             # Test in the other direction
1807              
1808 343         645 @d = @{ $wd[2] };
  343         842  
1809 343         565 $off = $wd[3];
1810 343         525 @d = @{ $dmb->calc_date_days(\@d,$off) };
  343         921  
1811              
1812 343 100       1164 if ($obj->__is_business_day(\@d,0)) {
1813 230         641 ($y,$m,$d,$h,$mn,$s) = @d;
1814 230         914 last;
1815             }
1816              
1817 113         441 $wd[2] = [@d];
1818             }
1819              
1820             }
1821             }
1822              
1823 2192 100       4444 if ($keep) {
1824 1994         5773 push(@keep,[$y,$m,$d,$h,$mn,$s]);
1825             }
1826             }
1827 2156         11259 @date = @keep;
1828             }
1829              
1830             #
1831             # Convert the dates to objects.
1832             #
1833              
1834 4050         6255 my(@ret);
1835              
1836 4050         6656 foreach my $date (@date) {
1837 4039         9327 my @d = @$date;
1838              
1839 4039         11219 my $obj = $self->new_date();
1840 4039         13532 $obj->set('date',\@d);
1841 4039 100       12431 if ($obj->err()) {
1842 1         5 push(@ret,undef);
1843             } else {
1844 4038         9873 push(@ret,$obj);
1845             }
1846             }
1847              
1848 4050         19671 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   13818 my($self,$n) = @_;
1856 7768 100       19001 return if (exists $$self{'data'}{'idate'}{$n});
1857 3913         6250 my $base = $$self{'data'}{'BASE'};
1858 3913         5287 my $date;
1859              
1860             # Get the interval date.
1861              
1862 3913 100       7753 if ($n == 0) {
1863 999         1490 $date = $base;
1864              
1865             } else {
1866 2914         9418 my @delta = $$self{'data'}{'delta'}->value;
1867 2914         5255 my $absn = abs($n);
1868 2914         5706 @delta = map { $absn*$_ } @delta;
  20398         31587  
1869 2914         8582 my $delta = $self->new_delta;
1870 2914         11421 $delta->set('delta',[@delta]);
1871 2914 100       12860 $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       10440 if ($$self{'data'}{'slow'}) {
1878              
1879 24 100       63 if ($n > 0) {
    100          
1880 14         57 $self->_nth_interval($n-1);
1881             } elsif ($n < 0) {
1882 5         21 $self->_nth_interval($n+1);
1883             }
1884             }
1885              
1886             # Get the list of events associated with this interval date.
1887              
1888 3913         10057 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         6481 my($n0,$n1);
1896 3913 100       8970 if ($$self{'data'}{'slow'}) {
1897              
1898 24 100       92 if (! @date) {
    100          
    100          
1899 4         10 $n0 = undef;
1900 4         9 $n1 = undef;
1901              
1902             } elsif ($n == 0) {
1903 4         9 $n0 = 0;
1904 4         11 $n1 = $#date;
1905              
1906             } elsif ($n > 0) {
1907 11         88 foreach (my $i = $n-1; $i >= 0; $i--) {
1908 14 100       53 next if (! defined $$self{'data'}{'idate'}{$i}[2]);
1909 10         20 $n0 = $$self{'data'}{'idate'}{$i}[2] + 1;
1910 10         18 last;
1911             }
1912 11 100       25 $n0 = 0 if (! defined $n0);
1913 11         21 $n1 = $n0 + $#date;
1914              
1915             } else {
1916 5         16 foreach (my $i = $n+1; $i <= 0; $i++) {
1917 5 100       30 next if (! defined $$self{'data'}{'idate'}{$i}[1]);
1918 4         10 $n1 = $$self{'data'}{'idate'}{$i}[1] - 1;
1919 4         8 last;
1920             }
1921 5 100       39 $n1 = -1 if (! defined $n1);
1922 5         13 $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         6408 $n0 = $n * $$self{'data'}{'ev_per_d'};
1936 3889         6682 $n1 = $n0 + $$self{'data'}{'ev_per_d'} - 1;
1937             }
1938              
1939             # Store the dates.
1940              
1941 3913         9675 for (my $i=0; $i<=$#date; $i++) {
1942 3809         13881 $$self{'data'}{'dates'}{$n0+$i} = $date[$i];
1943             }
1944              
1945             # Store the idate.
1946              
1947 3913 100       8179 if ($$self{'data'}{'slow'}) {
1948 24         107 $$self{'data'}{'idate'}{$n} = [$date,$n0,$n1];
1949             } else {
1950 3889         9811 $$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   4626 my($self,$op) = @_;
1959              
1960 2351 100       6676 return $$self{'data'}{$op} if (defined $$self{'data'}{$op});
1961              
1962 1152         2159 my $start = $$self{'data'}{'start'};
1963 1152         1909 my $end = $$self{'data'}{'end'};
1964 1152         1898 my $unmod = $$self{'data'}{'unmod_range'};
1965 1152         1838 my $dmt = $$self{'tz'};
1966 1152         1895 my $dmb = $$dmt{'base'};
1967 1152         3150 my $maxatt = $dmb->_config('maxrecurattempts');
1968              
1969 1152 100       3056 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         10 $i = 0;
1978 3         6 while (1) {
1979 7 100       22 last if (! exists $$self{'data'}{'dates'}{$i});
1980 5         10 my $date = $$self{'data'}{'dates'}{$i};
1981 5 100       16 if ($date->cmp($start) == -1) {
    50          
1982             # date < start : move to the next one
1983 4         8 $i++;
1984 4         12 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         9 $first = $i;
1991 1         5 last;
1992             }
1993             }
1994              
1995             # If we found one, find the last one
1996              
1997 3 100       9 if (defined($first)) {
1998 1         2 $i = $first;
1999 1         3 $last = $i;
2000 1         2 while (1) {
2001 4 50       15 last if (! exists $$self{'data'}{'dates'}{$i});
2002 4         7 my $date = $$self{'data'}{'dates'}{$i};
2003 4 100       11 if ($date->cmp($end) == 1) {
2004             # date > end : we're done
2005 1         4 last;
2006             } else {
2007             # date <= end : this might be the last one
2008 3         10 $last = $i;
2009 3         5 $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         9 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         2110 my($first_int,$last_int,$first,$last);
2043              
2044 1149 100       2821 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         8 $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         7 my $n = 0;
2075 4         7 while (1) {
2076 9 50       24 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         25 $self->_nth_interval($first_int);
2082 9         22 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2083 9 100       23 if (defined $ptr) {
2084 8         14 my $date = $$self{'data'}{'dates'}{$ptr};
2085 8 50       17 if (defined($date)) {
2086 8         13 $n = 0;
2087 8 100       24 last if ($date->cmp($start) < 0);
2088             } else {
2089 0         0 $n++;
2090             }
2091             } else {
2092 1         3 $n++;
2093             }
2094 5         12 $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       25 if ($unmod) {
2102 0         0 my $n = 0;
2103 0         0 while (1) {
2104 0 0       0 if ($n > $maxatt) {
2105 0         0 $$self{'err'} =
2106             "[_locate_n] Unable to find an interval in $maxatt attempts";
2107 0         0 return;
2108             }
2109 0         0 $self->_nth_interval($first_int);
2110 0         0 my $date = $$self{'data'}{'idate'}{$first_int}[0];
2111 0 0       0 if (defined($date)) {
2112 0         0 $n = 0;
2113 0 0       0 last if ($date->cmp($start) >= 0);
2114             } else {
2115 0         0 $n++;
2116             }
2117 0         0 $first_int++;
2118             }
2119 0         0 $first = $$self{'data'}{'idate'}{$first_int}[1];
2120              
2121             } else {
2122 4         8 my $n = 0;
2123 4         8 while (1) {
2124 11 50       24 if ($n > $maxatt) {
2125 0         0 $$self{'err'} =
2126             "[_locate_n] Unable to find an interval in $maxatt attempts";
2127 0         0 return;
2128             }
2129 11         31 $self->_nth_interval($first_int);
2130 11         25 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2131 11 100       22 if (defined $ptr) {
2132 10         21 my $date = $$self{'data'}{'dates'}{$ptr};
2133 10 50       20 if (defined($date)) {
2134 10         14 $n = 0;
2135 10 100       26 last if ($date->cmp($start) >= 0);
2136             } else {
2137 0         0 $n++;
2138             }
2139             } else {
2140 1         2 $n++;
2141             }
2142 7         20 $first_int++;
2143             }
2144              
2145 4         24 foreach my $i ($$self{'data'}{'idate'}{$first_int}[1] ..
2146             $$self{'data'}{'idate'}{$first_int}[2]) {
2147 4         12 my $date = $$self{'data'}{'dates'}{$i};
2148 4 50 33     17 if (defined $date && $date->cmp($start) >= 0) {
2149 4         14 $first = $i;
2150 4         9 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         9 $last_int = $first_int;
2159              
2160 4 50       15 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         9 my $n = 0;
2191 4         8 while (1) {
2192 14 50       26 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         38 $self->_nth_interval($last_int);
2198 14         33 my $ptr = $$self{'data'}{'idate'}{$last_int}[1];
2199 14 100       27 if (defined $ptr) {
2200 12         60 my $date = $$self{'data'}{'dates'}{$ptr};
2201 12 50       22 if (defined($date)) {
2202 12         18 $n = 0;
2203 12 100       33 last if ($date->cmp($end) > 0);
2204             } else {
2205 0         0 $n++;
2206             }
2207             } else {
2208 2         5 $n++;
2209             }
2210 10         22 $last_int++;
2211             }
2212 4         21 $last_int--;
2213              
2214 4         12 $last = undef;
2215 4         10 my $i = $first;
2216 4         8 while (1) {
2217 17 50       50 last if (! exists $$self{'data'}{'dates'}{$i});
2218 17         27 my $date = $$self{'data'}{'dates'}{$i};
2219 17 50       32 next if (! defined $date);
2220 17 100       38 last if ($date->cmp($end) > 0);
2221 13         21 $last = $i;
2222 13         17 $i++;
2223             }
2224             }
2225              
2226 4 50 33     27 return undef if (! defined $last ||
2227             $last < $first);
2228 4         16 $$self{'data'}{'first'} = $first;
2229 4         8 $$self{'data'}{'last'} = $last;
2230 4         12 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         1949 my $base = $$self{'data'}{'BASE'};
2245 1145         1988 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       4536 my $len = ($delta ? $delta->printf('%sys') : 0);
2248              
2249 1145 100       2774 my $targ = ($op eq 'first' ? $start : $end);
2250 1145         3563 my $diff = $base->calc($targ);
2251 1145         3497 my $tot = $diff->printf('%sys');
2252 1145 50       3983 my $nn = ($len ? int($tot/$len) : 1);
2253 1145         2766 my $ev = $$self{'data'}{'ev_per_d'};
2254              
2255             # Move backwards until we're completely before start
2256              
2257 1145         1878 $first_int = $nn;
2258 1145 100       2392 if ($unmod) {
2259 739         1054 my $n = 0;
2260 739         1089 while (1) {
2261 1492 50       3071 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         4206 $self->_nth_interval($first_int);
2267 1492         3197 my $date = $$self{'data'}{'idate'}{$first_int};
2268 1492 50       2870 if (defined($date)) {
2269 1492         2029 $n = 0;
2270 1492 100       3977 last if ($date->cmp($start) < 0);
2271             } else {
2272 0         0 $n++;
2273             }
2274 753         1475 $first_int--;
2275             }
2276              
2277             } else {
2278 406         828 my $n = 0;
2279             LOOP:
2280 406         684 while (1) {
2281 885 100       2102 if ($n > $maxatt) {
2282 1         7 $$self{'err'} =
2283             "[_locate_n] Unable to find an interval in $maxatt attempts";
2284 1         19 return;
2285             }
2286 884         2621 $self->_nth_interval($first_int);
2287 884         3201 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2288 1012 100       2532 if (exists $$self{'data'}{'dates'}{$i}) {
2289 816         1494 my $date = $$self{'data'}{'dates'}{$i};
2290 816 50       1524 if (defined($date)) {
2291 816         1255 $n = 0;
2292 816 100       2349 last LOOP if ($date->cmp($start) < 0);
2293             } else {
2294 0         0 $n++;
2295             }
2296             } else {
2297 196         459 $n++;
2298             }
2299             }
2300 479         814 $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       2901 if ($unmod) {
2308 739         1209 my $n = 0;
2309 739         1105 while (1) {
2310 1478 50       3039 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         3744 $self->_nth_interval($first_int);
2316 1478         2625 my $date = $$self{'data'}{'idate'}{$first_int};
2317 1478 50       2722 if (defined($date)) {
2318 1478         2066 $n = 0;
2319 1478 100       3236 last if ($date->cmp($start) >= 0);
2320             } else {
2321 0         0 $n++;
2322             }
2323 739         1465 $first_int++;
2324             }
2325              
2326             } else {
2327 405         789 my $n = 0;
2328             LOOP:
2329 405         712 while (1) {
2330 839 50       1975 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         2237 $self->_nth_interval($first_int);
2336 839         2572 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2337 963 100       2091 if (exists $$self{'data'}{'dates'}{$i}) {
2338 872         1619 my $date = $$self{'data'}{'dates'}{$i};
2339 872 50       1675 if (defined($date)) {
2340 872         1256 $n = 0;
2341 872 100       2018 last LOOP if ($date->cmp($start) >= 0);
2342             } else {
2343 0         0 $n++;
2344             }
2345             } else {
2346 91         182 $n++;
2347             }
2348             }
2349 434         777 $first_int++;
2350             }
2351             }
2352 1144         2293 $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         1869 $last_int = $first_int;
2358              
2359 1144 100       2419 if ($unmod) {
2360 739         1122 my $n = 0;
2361 739         1061 while (1) {
2362 1478 50       2857 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         3598 $self->_nth_interval($last_int);
2368 1478         2850 my $date = $$self{'data'}{'idate'}{$last_int};
2369 1478 50       2708 if (defined($date)) {
2370 1478         2010 $n = 0;
2371 1478 100       3538 last if ($date->cmp($end) > 0);
2372             } else {
2373 0         0 $n++;
2374             }
2375 739         1383 $last_int++;
2376             }
2377 739         1565 $last_int--;
2378              
2379             } else {
2380 405         751 my $n = 0;
2381             LOOP:
2382 405         650 while (1) {
2383 1462 50       2972 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         3717 $self->_nth_interval($last_int);
2389 1462         4632 for (my $i=($last_int+1)*$ev - 1; $i >= $last_int*$ev; $i--) {
2390 1701 100       4284 next if (! exists $$self{'data'}{'dates'}{$i});
2391 1544         2609 my $date = $$self{'data'}{'dates'}{$i};
2392 1544 50       2875 if (defined($date)) {
2393 1544         2277 $n = 0;
2394 1544 100       3968 last LOOP if ($date->cmp($end) >= 0);
2395             } else {
2396 0         0 $n++;
2397             }
2398             }
2399 1057         1746 $last_int++;
2400             }
2401             }
2402              
2403 1144         2563 $last = ($last_int+1)*$ev - 1;
2404              
2405             # Now get the actual first/last dates
2406              
2407 1144 100       2511 if ($unmod) {
2408 739         1115 while (1) {
2409             last if (exists $$self{'data'}{'dates'}{$first} &&
2410 739 100 66     3616 defined $$self{'data'}{'dates'}{$first});
2411 112         164 $first++;
2412 112 50       1032 return undef if ($first > $last);
2413             }
2414              
2415 627         941 while (1) {
2416             last if (exists $$self{'data'}{'dates'}{$last} &&
2417 627 50 33     2670 defined $$self{'data'}{'dates'}{$last});
2418 0         0 $last--;
2419             }
2420              
2421             } else {
2422 405         717 while (1) {
2423             last if (exists $$self{'data'}{'dates'}{$first} &&
2424             defined $$self{'data'}{'dates'}{$first} &&
2425 407 100 33     3168 $$self{'data'}{'dates'}{$first}->cmp($start) >= 0);
      66        
2426 2         9 $first++;
2427 2 50       9 return undef if ($first > $last);
2428             }
2429              
2430 405         882 while (1) {
2431             last if (exists $$self{'data'}{'dates'}{$last} &&
2432             defined $$self{'data'}{'dates'}{$last} &&
2433 954 100 66     5218 $$self{'data'}{'dates'}{$last}->cmp($end) <= 0);
      100        
2434 549         1011 $last--;
2435             }
2436             }
2437              
2438 1032 100 66     4844 return undef if (! defined $last ||
2439             $last < $first);
2440 934         2007 $$self{'data'}{'first'} = $first;
2441 934         1778 $$self{'data'}{'last'} = $last;
2442 934         9760 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   41 my($self,$y) = @_;
2450              
2451 21         39 my($c) = $y/100;
2452 21         34 my($g) = $y % 19;
2453 21         36 my($k) = ($c-17)/25;
2454 21         47 my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30;
2455 21         47 $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11));
2456 21         41 my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
2457 21         32 my($l) = $i-$j;
2458 21         34 my($m) = 3 + ($l+40)/44;
2459 21         38 my($d) = $l + 28 - 31*($m/4);
2460 21         80 return ($m,$d);
2461             }
2462              
2463             # This returns 1 if a field is empty.
2464             #
2465             sub _field_empty {
2466 12150     12150   18219 my($self,$val) = @_;
2467              
2468 12150 100       20574 if (ref($val)) {
2469 10839         17991 my @tmp = @$val;
2470 10839 100 100     55069 return 1 if ($#tmp == -1 ||
      100        
      66        
2471             ($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0]));
2472 7289         14590 return 0;
2473              
2474             } else {
2475 1311         2210 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   36264 my($self,$type,$val,@args) = @_;
2500 19788         28519 my $dmt = $$self{'tz'};
2501 19788         26014 my $dmb = $$dmt{'base'};
2502              
2503 19788 100       58102 if ($type eq 'h') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
2504 3962         6994 @args = (0,0,23,23);
2505              
2506             } elsif ($type eq 'mn') {
2507 3995         6840 @args = (0,0,59,59);
2508              
2509             } elsif ($type eq 's') {
2510 3995         7233 @args = (0,0,59,59);
2511              
2512             } elsif ($type eq 'y') {
2513 137         438 my $curry = $dmt->_now('y',1);
2514 137         290 foreach my $y (@$val) {
2515 213 100 66     784 $y = $curry if (! ref($y) && $y==0);
2516             }
2517              
2518 137         332 @args = (0,1,9999,9999);
2519              
2520             } elsif ($type eq 'm') {
2521 2953         5509 @args = (0,1,12,12);
2522              
2523             } elsif ($type eq 'week_of_year') {
2524 49         85 my($y) = @args;
2525 49         150 my $wiy = $dmb->weeks_in_year($y);
2526 49         123 @args = (1,1,$wiy,53);
2527              
2528             } elsif ($type eq 'dow_of_year') {
2529 164         280 my($y,$dow) = @args;
2530              
2531             # Get the 1st occurrence of $dow
2532 164         238 my $d0 = 1;
2533 164         542 my $dow0 = $dmb->day_of_week([$y,1,$d0]);
2534 164 100       593 if ($dow > $dow0) {
    100          
2535 15         90 $d0 += ($dow-$dow0);
2536             } elsif ($dow < $dow0) {
2537 119         190 $d0 += 7-($dow0-$dow);
2538             }
2539              
2540             # Get the last occurrence of $dow
2541 164         245 my $d1 = 31;
2542 164         445 my $dow1 = $dmb->day_of_week([$y,12,$d1]);
2543 164 100       450 if ($dow1 > $dow) {
    100          
2544 121         212 $d1 -= ($dow1-$dow);
2545             } elsif ($dow1 < $dow) {
2546 15         25 $d1 -= 7-($dow-$dow1);
2547             }
2548              
2549             # Find out the number of occurrenced of $dow
2550 164         471 my $doy1 = $dmb->day_of_year([$y,12,$d1]);
2551 164         341 my $n = ($doy1 - $d0)/7 + 1;
2552              
2553             # Get the list of @w
2554 164         359 @args = (1,1,$n,53);
2555              
2556             } elsif ($type eq 'dow_of_month') {
2557 826         1731 my($y,$m,$dow) = @args;
2558              
2559             # Get the 1st occurrence of $dow in the month
2560 826         1179 my $d0 = 1;
2561 826         2966 my $dow0 = $dmb->day_of_week([$y,$m,$d0]);
2562 826 100       2920 if ($dow > $dow0) {
    100          
2563 185         491 $d0 += ($dow-$dow0);
2564             } elsif ($dow < $dow0) {
2565 504         900 $d0 += 7-($dow0-$dow);
2566             }
2567              
2568             # Get the last occurrence of $dow
2569 826         1964 my $d1 = $dmb->days_in_month($y,$m);
2570 826         2436 my $dow1 = $dmb->day_of_week([$y,$m,$d1]);
2571 826 100       2478 if ($dow1 > $dow) {
    100          
2572 526         920 $d1 -= ($dow1-$dow);
2573             } elsif ($dow1 < $dow) {
2574 180         414 $d1 -= 7-($dow-$dow1);
2575             }
2576              
2577             # Find out the number of occurrenced of $dow
2578 826         1443 my $n = ($d1 - $d0)/7 + 1;
2579              
2580             # Get the list of @w
2581 826         1868 @args = (1,1,$n,5);
2582              
2583             } elsif ($type eq 'day_of_year') {
2584 171         289 my($y) = @args;
2585 171         515 my $diy = $dmb->days_in_year($y);
2586 171         380 @args = (1,1,$diy,366);
2587              
2588             } elsif ($type eq 'day_of_month') {
2589 2810         4905 my($y,$m) = @args;
2590 2810         7716 my $dim = $dmb->days_in_month($y,$m);
2591 2810         6201 @args = (1,1,$dim,31);
2592              
2593             } elsif ($type eq 'day_of_week') {
2594 726         1331 @args = (0,1,7,7);
2595             }
2596              
2597 19788         34244 my($err,@vals) = $self->__rtime_values($val,@args);
2598 19788 50       36159 if ($err) {
2599 0         0 $$self{'err'} = "[dates] $err [$type]";
2600 0         0 return (1);
2601             }
2602 19788         43006 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   32948 my($self,$vals,$allowneg,$min,$max,$absmax) = @_;
2622 19788         24662 my(@ret);
2623              
2624 19788         32118 foreach my $val (@$vals) {
2625              
2626 20337 100       30865 if (ref($val)) {
2627 24         40 my($val1,$val2) = @$val;
2628              
2629 24 50       62 if ($allowneg) {
2630 24 0 33     192 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     151 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     134 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       53 $val1 = $max + $val1 + 1 if ($val1 < 0); # day -10
2652 24 50       46 $val2 = $max + $val2 + 1 if ($val2 < 0);
2653              
2654 24 50       50 $val1 = $min if ($val1 < $min); # day -31 in a 30 day month
2655 24 50       64 $val2 = $max if ($val2 > $max);
2656              
2657 24 100       53 next if ($val1 > $val2);
2658              
2659 20         56 push(@ret,$val1..$val2);
2660              
2661             } else {
2662              
2663 20313 100       30442 if ($allowneg) {
2664 4193 50 33     17250 return ('Value outside range')
      66        
2665             if ($val >= 0 && ($val < $min || $val > $absmax));
2666 4193 50 33     9440 return ('Negative value outside range')
      66        
2667             if ($val <= 0 && ($val < -$absmax || $val > -$min));
2668             } else {
2669 16120 50 33     47929 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         25227 my $ret;
2677 20313 100       29794 if ($val < 0 ) {
2678 401         592 $ret = $max + $val + 1;
2679             } else {
2680 19912         25516 $ret = $val;
2681             }
2682              
2683 20313 100 100     53670 next if ($ret > $max || $ret < $min);
2684 19925         34655 push(@ret,$ret);
2685             }
2686             }
2687              
2688 19788         46686 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   21110 my($self,$datesref,$n,@val) = @_;
2697              
2698 11952         17188 my @dates = @$datesref;
2699 11952         14390 my @tmp;
2700              
2701 11952         17953 foreach my $date (@dates) {
2702 12397         21077 my @d = @$date;
2703 12397         16842 foreach my $val (@val) {
2704 12465         18417 $d[$n] = $val;
2705 12465         34530 push(@tmp,[@d]);
2706             }
2707             }
2708              
2709 11952         28907 @$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: