← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:48 2015

Filename/usr/share/perl5/Date/Manip/Recur.pm
StatementsExecuted 49 statements in 8.20ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11120µs28µsDate::Manip::Recur::::_initDate::Manip::Recur::_init
11110µs10µsDate::Manip::Recur::::BEGIN@14Date::Manip::Recur::BEGIN@14
1119µs120µsDate::Manip::Recur::::BEGIN@22Date::Manip::Recur::BEGIN@22
1118µs16µsDate::Manip::Recur::::BEGIN@18Date::Manip::Recur::BEGIN@18
1117µs9µsDate::Manip::Recur::::BEGIN@20Date::Manip::Recur::BEGIN@20
1117µs9µsDate::Manip::Recur::::BEGIN@21Date::Manip::Recur::BEGIN@21
1116µs18µsDate::Manip::Recur::::BEGIN@19Date::Manip::Recur::BEGIN@19
1115µs5µsDate::Manip::Recur::::BEGIN@25Date::Manip::Recur::BEGIN@25
1115µs5µsDate::Manip::Recur::::ENDDate::Manip::Recur::END
1114µs4µsDate::Manip::Recur::::BEGIN@26Date::Manip::Recur::BEGIN@26
0000s0sDate::Manip::Recur::::__rtime_valuesDate::Manip::Recur::__rtime_values
0000s0sDate::Manip::Recur::::_actual_baseDate::Manip::Recur::_actual_base
0000s0sDate::Manip::Recur::::_apply_rtime_modsDate::Manip::Recur::_apply_rtime_mods
0000s0sDate::Manip::Recur::::_dateDate::Manip::Recur::_date
0000s0sDate::Manip::Recur::::_easterDate::Manip::Recur::_easter
0000s0sDate::Manip::Recur::::_errorDate::Manip::Recur::_error
0000s0sDate::Manip::Recur::::_field_add_valuesDate::Manip::Recur::_field_add_values
0000s0sDate::Manip::Recur::::_field_emptyDate::Manip::Recur::_field_empty
0000s0sDate::Manip::Recur::::_holidayDate::Manip::Recur::_holiday
0000s0sDate::Manip::Recur::::_init_argsDate::Manip::Recur::_init_args
0000s0sDate::Manip::Recur::::_init_datesDate::Manip::Recur::_init_dates
0000s0sDate::Manip::Recur::::_locate_nDate::Manip::Recur::_locate_n
0000s0sDate::Manip::Recur::::_nth_intervalDate::Manip::Recur::_nth_interval
0000s0sDate::Manip::Recur::::_parse_langDate::Manip::Recur::_parse_lang
0000s0sDate::Manip::Recur::::_rtime_valuesDate::Manip::Recur::_rtime_values
0000s0sDate::Manip::Recur::::_rxDate::Manip::Recur::_rx
0000s0sDate::Manip::Recur::::basedateDate::Manip::Recur::basedate
0000s0sDate::Manip::Recur::::datesDate::Manip::Recur::dates
0000s0sDate::Manip::Recur::::endDate::Manip::Recur::end
0000s0sDate::Manip::Recur::::frequencyDate::Manip::Recur::frequency
0000s0sDate::Manip::Recur::::is_recurDate::Manip::Recur::is_recur
0000s0sDate::Manip::Recur::::modifiersDate::Manip::Recur::modifiers
0000s0sDate::Manip::Recur::::nextDate::Manip::Recur::next
0000s0sDate::Manip::Recur::::nthDate::Manip::Recur::nth
0000s0sDate::Manip::Recur::::parseDate::Manip::Recur::parse
0000s0sDate::Manip::Recur::::prevDate::Manip::Recur::prev
0000s0sDate::Manip::Recur::::startDate::Manip::Recur::start
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Date::Manip::Recur;
2# Copyright (c) 1998-2014 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
14255µs110µs
# spent 10µs within Date::Manip::Recur::BEGIN@14 which was called: # once (10µs+0s) by Date::Manip::Obj::new_recur at line 14
use Date::Manip::Obj;
# spent 10µs making 1 call to Date::Manip::Recur::BEGIN@14
15112µs@ISA = ('Date::Manip::Obj');
16
1719µsrequire 5.010000;
18221µs223µs
# spent 16µs (8+7) within Date::Manip::Recur::BEGIN@18 which was called: # once (8µs+7µs) by Date::Manip::Obj::new_recur at line 18
use warnings;
# spent 16µs making 1 call to Date::Manip::Recur::BEGIN@18 # spent 7µs making 1 call to warnings::import
19224µs230µs
# spent 18µs (6+12) within Date::Manip::Recur::BEGIN@19 which was called: # once (6µs+12µs) by Date::Manip::Obj::new_recur at line 19
use strict;
# spent 18µs making 1 call to Date::Manip::Recur::BEGIN@19 # spent 12µs making 1 call to strict::import
20218µs210µs
# spent 9µs (7+2) within Date::Manip::Recur::BEGIN@20 which was called: # once (7µs+2µs) by Date::Manip::Obj::new_recur at line 20
use integer;
# spent 9µs making 1 call to Date::Manip::Recur::BEGIN@20 # spent 2µs making 1 call to integer::import
21219µs211µs
# spent 9µs (7+2) within Date::Manip::Recur::BEGIN@21 which was called: # once (7µs+2µs) by Date::Manip::Obj::new_recur at line 21
use utf8;
# spent 9µs making 1 call to Date::Manip::Recur::BEGIN@21 # spent 2µs making 1 call to utf8::import
22226µs2231µs
# spent 120µs (9+111) within Date::Manip::Recur::BEGIN@22 which was called: # once (9µs+111µs) by Date::Manip::Obj::new_recur at line 22
use IO::File;
# spent 120µs making 1 call to Date::Manip::Recur::BEGIN@22 # spent 111µs making 1 call to Exporter::import
23#use re 'debug';
24
25220µs15µs
# spent 5µs within Date::Manip::Recur::BEGIN@25 which was called: # once (5µs+0s) by Date::Manip::Obj::new_recur at line 25
use Date::Manip::Base;
# spent 5µs making 1 call to Date::Manip::Recur::BEGIN@25
2627.96ms14µs
# spent 4µs within Date::Manip::Recur::BEGIN@26 which was called: # once (4µs+0s) by Date::Manip::Obj::new_recur at line 26
use Date::Manip::TZ;
# spent 4µs making 1 call to Date::Manip::Recur::BEGIN@26
27
281100nsour $VERSION;
291300ns$VERSION='6.47';
3015µs
# spent 5µs within Date::Manip::Recur::END which was called: # once (5µs+0s) by main::RUNTIME at line 131 of C4/Service.pm
END { undef $VERSION; }
31
32########################################################################
33# BASE METHODS
34########################################################################
35
36sub is_recur {
37 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
# spent 28µs (20+8) within Date::Manip::Recur::_init which was called: # once (20µs+8µs) by Date::Manip::Obj::new at line 162 of Date/Manip/Obj.pm
sub _init {
441300ns my($self) = @_;
4513µs my $dmt = $$self{'tz'};
461200ns my $dmb = $$dmt{'base'};
47
481300ns $$self{'err'} = '';
49
501400ns $$self{'data'}{'freq'} = ''; # The frequency
511600ns $$self{'data'}{'flags'} = []; # Modifiers
521500ns $$self{'data'}{'base'} = undef; # The specified base date
531300ns $$self{'data'}{'BASE'} = undef; # The actual base date
541300ns $$self{'data'}{'start'} = undef; # Start and end date
551400ns $$self{'data'}{'end'} = undef;
561500ns $$self{'data'}{'holiday'} = 0; # If this is 1, the start/end data
57 # actually apply to the interval dates
58 # instead of the final dates. This is
59 # only used in determining holidays
60 # currently.
611900ns $$self{'data'}{'saved'} = {}; # I => 1 if date I is stored as a holiday
62
631400ns $$self{'data'}{'interval'} = []; # (Y, M, ...)
641400ns $$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
65 # [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
66 # ... )
671300ns $$self{'data'}{'slow'} = 0; # 1 if a range of the form 2--2 is
68 # included.
691400ns $$self{'data'}{'ev_per_d'} = 0; # The number of events per interval date.
701300ns $$self{'data'}{'delta'} = undef; # The offset based on the interval.
711300ns $$self{'data'}{'noint'} = 1; # 0 if an interval is present
72 # 1 if no interval is present and dates
73 # not done
74 # 2 if no interval is present and dates
75 # done
76
771300ns $$self{'data'}{'idate'} = {}; # { N => Nth interval date } for non-slow
78 # { N => [Nth interval date,X,Y] } for slow
79 # [X,Y] are the first/last event indices
80 # generated by this interval date.
8111µs $$self{'data'}{'dates'} = {}; # { N => Nth recurring event }
82 # N is relative to the base date and is not
83 # affected by start/end
841200ns $$self{'data'}{'curr'} = undef; # Iterator pointer
851300ns $$self{'data'}{'first'} = undef; # N : the first date in a range
861300ns $$self{'data'}{'last'} = undef; # N : the last date in a range
87
88 # Get the default start/end dates
89
9012µs18µs my $range = $dmb->_config('recurrange');
# spent 8µs making 1 call to Date::Manip::TZ_Base::_config
91
9213µs if ($range eq 'none') {
931300ns $$self{'data'}{'start'} = undef;
941200ns $$self{'data'}{'end'} = undef;
95
96 } elsif ($range eq 'year') {
97 my $y = $dmt->_now('y',1);
98 my $start = $self->new_date();
99 my $end = $self->new_date();
100 $start->set('date',[$y, 1, 1,00,00,00]);
101 $end->set ('date',[$y,12,31,23,59,59]);
102
103 } elsif ($range eq 'month') {
104 my ($y,$m) = $dmt->_now('now',1);
105 my $dim = $dmb->days_in_month($y,$m);
106 my $start = $self->new_date();
107 my $end = $self->new_date();
108 $start->set('date',[$y,$m, 1,00,00,00]);
109 $end->set ('date',[$y,$m,$dim,23,59,59]);
110
111 } elsif ($range eq 'week') {
112 my($y,$m,$d) = $dmt->_now('now',1);
113 my $w;
114 ($y,$w) = $dmb->week_of_year([$y,$m,$d]);
115 ($y,$m,$d) = @{ $dmb->week_of_year($y,$w) };
116 my($yy,$mm,$dd)
117 = @{ $dmb->_calc_date_ymwd([$y,$m,$d], [0,0,0,6], 0) };
118
119 my $start = $self->new_date();
120 my $end = $self->new_date();
121 $start->set('date',[$y, $m, $d, 00,00,00]);
122 $end->set ('date',[$yy,$mm,$dd,23,59,59]);
123
124 } elsif ($range eq 'day') {
125 my($y,$m,$d) = $dmt->_now('now',1);
126 my $start = $self->new_date();
127 my $end = $self->new_date();
128 $start->set('date',[$y,$m,$d,00,00,00]);
129 $end->set ('date',[$y,$m,$d,23,59,59]);
130
131 } elsif ($range eq 'all') {
132 my $start = $self->new_date();
133 my $end = $self->new_date();
134 $start->set('date',[0001,02,01,00,00,00]);
135 $end->set ('date',[9999,11,30,23,59,59]);
136 }
137}
138
139# If $keep is 1, it will keep any existing base date and cached
140# dates, but it will reset other things.
141#
142sub _init_dates {
143 my($self,$keep) = @_;
144
145 if (! $keep) {
146 $$self{'data'}{'base'} = undef;
147 $$self{'data'}{'BASE'} = undef;
148 $$self{'data'}{'idate'} = {};
149 $$self{'data'}{'dates'} = {};
150 $$self{'data'}{'saved'} = {};
151 }
152 $$self{'data'}{'curr'} = undef;
153 $$self{'data'}{'first'} = undef;
154 $$self{'data'}{'last'} = undef;
155}
156
157sub _init_args {
158 my($self) = @_;
159
160 my @args = @{ $$self{'args'} };
161 if (@args) {
162 $self->parse(@args);
163 }
164}
165
166sub _holiday {
167 my($self,$val) = @_;
168 if ($val) {
169 $$self{'data'}{'holiday'} = $val;
170 } else {
171 $$self{'data'}{'holiday'} = 1;
172 }
173}
174
175########################################################################
176# METHODS
177########################################################################
178
179sub parse {
180 my($self,$string,@args) = @_;
181
182 # Test if $string = FREQ
183
184 my $err = $self->frequency($string);
185 if (! $err) {
186 $string = '';
187 }
188
189 # Test if $string = "FREQ*..." and FREQ contains an '*'.
190
191 if ($err) {
192 $self->err(1);
193
194 $string =~ s/\s*\*\s*/\*/g;
195
196 if ($string =~ /^([^*]*\*[^*]*)\*/) {
197 # Everything up to the 2nd '*'
198 my $freq = $1;
199 $err = $self->frequency($freq);
200 if (! $err) {
201 $string =~ s/^\Q$freq\E\*//;
202 }
203 } else {
204 $err = 1;
205 }
206 }
207
208 # Test if $string = "FREQ*..." and FREQ does NOT contains an '*'.
209
210 if ($err) {
211 $self->err(1);
212
213 if ($string =~ s/^([^*]*)\*//) {
214 my $freq = $1;
215 $err = $self->frequency($freq);
216 if (! $err) {
217 $string =~ s/^\Q$freq\E\*//;
218 }
219 } else {
220 $err = 1;
221 }
222 }
223
224 if ($err) {
225 $$self{'err'} = "[parse] Invalid frequency string";
226 return 1;
227 }
228
229 # Handle MODIFIERS from string and arguments
230
231 my @string = split(/\*/,$string);
232
233 if (@string) {
234 my $tmp = shift(@string);
235 $err = $self->modifiers($tmp) if ($tmp);
236 return 1 if ($err);
237 }
238 if (@args == 1 || @args == 4) {
239 my $tmp = shift(@args);
240 if ($tmp && ! ref($tmp)) {
241 $err = $self->modifiers($tmp);
242 return 1 if ($err);
243 }
244 }
245
246 # Handle BASE
247
248 if (@string) {
249 my $tmp = shift(@string);
250 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
251 return 1 if ($err);
252 }
253 if (@args == 3) {
254 my $tmp = $args[0];
255 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
256 return 1 if ($err);
257 }
258
259 # Handle START
260
261 if (@string) {
262 my $tmp = shift(@string);
263 $err = $self->start($tmp) if (defined($tmp) && $tmp);
264 return 1 if ($err);
265 }
266 if (@args == 3) {
267 my $tmp = $args[1];
268 $err = $self->start($tmp) if (defined($tmp) && $tmp);
269 return 1 if ($err);
270 }
271
272 # END
273
274 if (@string) {
275 my $tmp = shift(@string);
276 $err = $self->end($tmp) if (defined($tmp) && $tmp);
277 return 1 if ($err);
278 }
279 if (@args == 3) {
280 my $tmp = $args[2];
281 @args = ();
282 $err = $self->end($tmp) if (defined($tmp) && $tmp);
283 return 1 if ($err);
284 }
285
286 # Remaining arguments are invalid.
287
288 if (@string) {
289 $$self{'err'} = "[parse] String contains invalid elements";
290 return 1;
291 }
292 if (@args) {
293 $$self{'err'} = "[parse] Unknown arguments";
294 return 1;
295 }
296
297 return 0;
298}
299
300sub frequency {
301 my($self,$string) = @_;
302 return $$self{'data'}{'freq'} if (! defined $string);
303
304 $self->_init();
305 my (@int,@rtime);
306
307 PARSE: {
308
309 # Standard frequency notation
310
311 my $stdrx = $self->_rx('std');
312 if ($string =~ $stdrx) {
313 my($l,$r) = @+{qw(l r)};
314
315 if (defined($l)) {
316 $l =~ s/^\s*:/0:/;
317 $l =~ s/:\s*$/:0/;
318 $l =~ s/::/:0:/g;
319
320 @int = split(/:/,$l);
321 }
322
323 if (defined($r)) {
324 $r =~ s/^\s*:/0:/;
325 $r =~ s/:\s*$/:0/;
326 $r =~ s/::/:0:/g;
327
328 @rtime = split(/:/,$r);
329 }
330
331 last PARSE;
332 }
333
334 # Other frequency strings
335
336 # Strip out some words to ignore
337
338 my $ignrx = $self->_rx('ignore');
339 $string =~ s/$ignrx/ /g;
340
341 my $eachrx = $self->_rx('each');
342 my $each = 0;
343 if ($string =~ s/$eachrx/ /g) {
344 $each = 1;
345 }
346
347 $string =~ s/\s*$//;
348
349 if (! $string) {
350 $$self{'err'} = "[frequency] Invalid frequency string";
351 return 1;
352 }
353
354 my($l,$r);
355 my $err = $self->_parse_lang($string);
356 if ($err) {
357 $$self{'err'} = "[frequency] Invalid frequency string";
358 return 1;
359 }
360 return 0;
361 }
362
363 # If the interval consists only of zeros, the last entry is changed
364 # to 1.
365
366 if (@int) {
367 TEST_INT: {
368 for my $i (@int) {
369 last TEST_INT if ($i);
370 }
371 $int[$#int] = 1;
372 }
373 }
374
375 # If @int contains 2 or 3 elements, move a trailing 0 to the start
376 # of @rtime.
377 #
378 # Y:M:0 * D:H:MN:S => Y:M * 0:D:H:MN:S
379
380 while (@int &&
381 ($#int == 1 || $#int == 2) &&
382 ($int[$#int] == 0)) {
383 pop(@int);
384 unshift(@rtime,0);
385 }
386
387 # Test the format of @rtime.
388 #
389 # Turn it to:
390 # @rtime = ( NUM|RANGE, NUM|RANGE, ...)
391 # where
392 # NUM is an integer
393 # RANGE is [NUM1,NUM2]
394
395 my $rfieldrx = $self->_rx('rfield');
396 my $rrangerx = $self->_rx('rrange');
397 my @type = qw(y m w d h mn s);
398 while ($#type > $#rtime) {
399 shift(@type);
400 }
401
402 foreach my $rfield (@rtime) {
403 my $type = shift(@type);
404
405 if ($rfield !~ $rfieldrx) {
406 $$self{'err'} = "[frequency] Invalid rtime string";
407 return 1;
408 }
409
410 my @rfield = split(/,/,$rfield);
411 my @val;
412
413 foreach my $vals (@rfield) {
414 if ($vals =~ $rrangerx) {
415 my ($num1,$num2) = ($1,$2);
416
417 if ( ($num1 < 0 || $num2 < 0) &&
418 ($type ne 'w' && $type ne 'd') ) {
419 $$self{'err'} = "[frequency] Negative values allowed for day/week";
420 return 1;
421 }
422
423 if ( ($num1 > 0 && $num2 > 0) ||
424 ($num1 < 0 && $num2 < 0) ) {
425 if ($num1 > $num2) {
426 $$self{'err'} = "[frequency] Invalid rtime range string";
427 return 1;
428 }
429 push(@val,$num1..$num2);
430 } else {
431 push(@val,[$num1,$num2]);
432 }
433
434 } else {
435 if ($vals < 0 &&
436 ($type ne 'w' && $type ne 'd') ) {
437 $$self{'err'} = "[frequency] Negative values allowed for day/week";
438 return 1;
439 }
440 push(@val,$vals);
441 }
442 }
443
444 $rfield = [ @val ];
445 }
446
447 # Store it
448
449 $$self{'data'}{'interval'} = [ @int ];
450 $$self{'data'}{'rtime'} = [ @rtime ];
451
452 # Analyze the rtime to see if it's slow, and to get the number of
453 # events per interval date.
454
455 my $freq = join(':',@int);
456 my $slow = 0;
457 my $n = 1;
458 if (@rtime) {
459 $freq .= '*';
460 my (@tmp);
461
462 foreach my $rtime (@rtime) {
463 my @t2;
464 foreach my $tmp (@$rtime) {
465 if (ref($tmp)) {
466 my($a,$b) = @$tmp;
467 push(@t2,"$a-$b");
468 $slow = 1;
469 } else {
470 push(@t2,$tmp);
471 }
472 }
473 my $tmp = join(',',@t2);
474 push(@tmp,$tmp);
475 my $nn = @t2;
476 $n *= $nn;
477 }
478 $freq .= join(':',@tmp);
479 }
480 $$self{'data'}{'freq'} = $freq;
481 $$self{'data'}{'slow'} = $slow;
482 $$self{'data'}{'ev_per_d'} = $n if (! $slow);
483
484 if (@int) {
485 $$self{'data'}{'noint'} = 0;
486
487 while (@int < 7) {
488 push(@int,0);
489 }
490 my $delta = $self->new_delta();
491 $delta->set('delta',[@int]);
492 $$self{'data'}{'delta'} = $delta;
493
494 } else {
495 $$self{'data'}{'noint'} = 1;
496 }
497
498 return 0;
499}
500
501sub _parse_lang {
502 my($self,$string) = @_;
503 my $dmt = $$self{'tz'};
504 my $dmb = $$dmt{'base'};
505
506 # Test the regular expression
507
508 my $rx = $self->_rx('every');
509
510 return 1 if ($string !~ $rx);
511 my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) =
512 @+{qw(month week day last nth day_name day_abb mon_name mon_abb n y)};
513
514 # Convert wordlist values to calendar values
515
516 my $dow;
517 if (defined($day_name) || defined($day_abb)) {
518 if (defined($day_name)) {
519 $dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{lc($day_name)};
520 } else {
521 $dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{lc($day_abb)};
522 }
523 }
524
525 my $mmm;
526 if (defined($mon_name) || defined($mon_abb)) {
527 if (defined($mon_name)) {
528 $mmm = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($mon_name)};
529 } else {
530 $mmm = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mon_abb)};
531 }
532 }
533
534 if (defined($nth)) {
535 $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
536 }
537
538 # Get the frequencies
539
540 my($freq);
541 if (defined($dow)) {
542 if (defined($mmm)) {
543 if (defined($last)) {
544 # last DoW in MMM [YY]
545 $freq = "1*$mmm:-1:$dow:0:0:0";
546
547 } elsif (defined($nth)) {
548 # Nth DoW in MMM [YY]
549 $freq = "1*$mmm:$nth:$dow:0:0:0";
550
551 } else {
552 # every DoW in MMM [YY]
553 $freq = "1*$mmm:1-5:$dow:0:0:0";
554 }
555
556 } else {
557 if (defined($last)) {
558 # last DoW in every month [in YY]
559 $freq = "0:1*-1:$dow:0:0:0";
560
561 } elsif (defined($nth)) {
562 # Nth DoW in every month [in YY]
563 $freq = "0:1*$nth:$dow:0:0:0";
564
565 } else {
566 # every DoW in every month [in YY]
567 $freq = "0:1*1-5:$dow:0:0:0";
568 }
569 }
570
571 } elsif (defined($day)) {
572 if (defined($month)) {
573 if (defined($nth)) {
574 # Nth day of every month [YY]
575 $freq = "0:1*0:$nth:0:0:0";
576
577 } elsif (defined($last)) {
578 # last day of every month [YY]
579 $freq = "0:1*0:-1:0:0:0";
580
581 } else {
582 # every day of every month [YY]
583 $freq = "0:0:0:1*0:0:0";
584 }
585
586 } else {
587 if (defined($nth)) {
588 # every Nth day [YY]
589 $freq = "0:0:0:$nth*0:0:0";
590
591 } elsif (defined($n)) {
592 # every N days [YY]
593 $freq = "0:0:0:$n*0:0:0";
594
595 } else {
596 # every day [YY]
597 $freq = "0:0:0:1*0:0:0";
598 }
599 }
600 }
601
602 # Get the range (if YY is included)
603
604 if (defined($y)) {
605 $y = $dmt->_fix_year($y);
606 my $start = "${y}010100:00:00";
607 my $end = "${y}123123:59:59";
608
609 return $self->parse($freq,undef,$start,$end);
610 }
611
612 return $self->frequency($freq)
613}
614
615sub _date {
616 my($self,$op,$date_or_string) = @_;
617
618 # Make sure the argument is a date
619
620 if (ref($date_or_string) eq 'Date::Manip::Date') {
621 $$self{'data'}{$op} = $date_or_string;
622
623 } elsif (ref($date_or_string)) {
624 $$self{'err'} = "[$op] Invalid date object";
625 return 1;
626
627 } else {
628 my $date = $self->new_date();
629 my $err = $date->parse($date_or_string);
630 if ($err) {
631 $$self{'err'} = "[$op] Invalid date string";
632 return 1;
633 }
634 $$self{'data'}{$op} = $date;
635 }
636
637 return 0;
638}
639
640sub start {
641 my($self,$start) = @_;
642 return $$self{'data'}{'start'} if (! defined $start);
643
644 $self->_init_dates(1);
645 $self->_date('start',$start);
646}
647
648sub end {
649 my($self,$end) = @_;
650 return $$self{'data'}{'end'} if (! defined $end);
651
652 $self->_init_dates(1);
653 $self->_date('end',$end);
654}
655
656sub basedate {
657 my($self,$base) = @_;
658 return ($$self{'data'}{'base'},$$self{'data'}{'BASE'}) if (! defined $base);
659
660 $self->_init_dates();
661 $self->_date('base',$base);
662}
663
664sub modifiers {
665 my($self,@flags) = @_;
666 return @{ $$self{'data'}{'flags'} } if (! @flags);
667
668 my $dmt = $$self{'tz'};
669 my $dmb = $$dmt{'base'};
670 if (@flags == 1) {
671 @flags = split(/,/,lc($flags[0]));
672 }
673
674 # Add these flags to the list
675
676 if (@flags && $flags[0] eq "+") {
677 shift(@flags);
678 my @tmp = @{ $$self{'data'}{'flags'} };
679 @flags = (@tmp,@flags) if (@tmp);
680 }
681
682 # Return an error if any modifier is unknown
683
684 foreach my $flag (@flags) {
685 next if ($flag =~ /^([pn][dt][1-7]|wd[1-7]|[fb][dw]\d+|cw[dnp]|[npd]wd|[in]bd|easter)$/);
686 $$self{'err'} = "[modifiers] Invalid modifier: $flag";
687 return 1;
688 }
689
690 $$self{'data'}{'flags'} = [ @flags ];
691 $self->_init_dates();
692
693 return 0;
694}
695
696sub nth {
697 my($self,$n) = @_;
698 $n = 0 if (! $n);
699 return ($$self{'data'}{'dates'}{$n},0) if (exists $$self{'data'}{'dates'}{$n});
700
701 my ($err) = $self->_error();
702 return (undef,$err) if ($err);
703
704 if ($$self{'data'}{'noint'}) {
705 return ($$self{'data'}{'dates'}{$n},0)
706 if (exists $$self{'data'}{'dates'}{$n});
707 return (undef,0);
708 }
709
710 if ($$self{'data'}{'slow'}) {
711 my $nn = 0;
712 while (1) {
713 $self->_nth_interval($nn);
714 return ($$self{'data'}{'dates'}{$n},0)
715 if (exists $$self{'data'}{'dates'}{$n});
716 if ($n >= 0) {
717 $nn++;
718 } else {
719 $nn--;
720 }
721 }
722
723 } else {
724 my $nn;
725 if ($n >= 0) {
726 $nn = int($n/$$self{'data'}{'ev_per_d'});
727 } else {
728 $nn = int(($n+1)/$$self{'data'}{'ev_per_d'}) -1;
729 }
730 $self->_nth_interval($nn);
731 return ($$self{'data'}{'dates'}{$n},0);
732 }
733}
734
735sub next {
736 my($self) = @_;
737
738 my ($err) = $self->_error();
739 return (undef,$err) if ($err);
740
741 # If curr is not set, we have to get it.
742
743 if (! defined $$self{'data'}{'curr'}) {
744
745 CURR:
746 while (1) {
747
748 # If no interval then
749 # return base date
750
751 if ($$self{'data'}{'noint'}) {
752 $$self{'data'}{'curr'} = -1;
753 last CURR;
754 }
755
756 # If a range is defined
757 # find first event in range and return it
758
759 if (defined $$self{'data'}{'start'} &&
760 defined $$self{'data'}{'end'}) {
761
762 my $n = $self->_locate_n('first');
763 $$self{'data'}{'curr'} = $n-1;
764
765 } else {
766 $$self{'data'}{'curr'} = -1;
767 }
768 last CURR;
769 }
770 }
771
772 # With curr set, find the next defined one
773
774 while (1) {
775 $$self{'data'}{'curr'}++;
776 if ($$self{'data'}{'noint'}) {
777 return (undef,0)
778 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
779 }
780 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
781 return (undef,$e) if ($e);
782 return ($d,0) if (defined $d);
783 }
784}
785
786sub prev {
787 my($self) = @_;
788
789 my ($err) = $self->_error();
790 return (undef,$err) if ($err);
791
792 # If curr is not set, we have to get it.
793
794 if (! defined $$self{'data'}{'curr'}) {
795
796 CURR:
797 while (1) {
798
799 # If no interval then
800 # return last one
801
802 if ($$self{'data'}{'noint'}) {
803 my @n = sort { $a <=> $b } keys %{ $$self{'data'}{'dates'} };
804 $$self{'data'}{'curr'} = pop(@n) + 1;
805 last CURR;
806 }
807
808 # If a range is defined
809 # find last event in range and return it
810
811 if (defined $$self{'data'}{'start'} &&
812 defined $$self{'data'}{'end'}) {
813
814 my $n = $self->_locate_n('last');
815 $$self{'data'}{'curr'} = $n+1;
816
817 } else {
818 $$self{'data'}{'curr'} = 0;
819 }
820 last CURR;
821 }
822 }
823
824 # With curr set, find the previous defined one
825
826 while (1) {
827 $$self{'data'}{'curr'}--;
828 if ($$self{'data'}{'noint'}) {
829 return (undef,0)
830 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
831 }
832 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
833 return (undef,$e) if ($e);
834 return ($d,0) if (defined $d);
835 }
836}
837
838sub dates {
839 my($self,$start2,$end2) = @_;
840 $self->err(1);
841
842 # If $start2 or $end2 are provided, make sure they are valid.
843 # If either are provided, make a note of it ($tmp_limits).
844
845 my $tmp_limits = 0;
846 $tmp_limits = 1 if ($start2 || $end2);
847
848 # Check the recurrence for errors. If both $start2 and $end2 are
849 # provided, it's not necessary for a range to be in the recurrence.
850
851 my $range_required;
852 if (defined($start2) && defined($end2)) {
853 $range_required = 0;
854 } else {
855 $range_required = 1;
856 }
857
858 my($err);
859 ($err,$start2,$end2) = $self->_error($range_required,$start2,$end2);
860 return () if ($err);
861
862 # If $start2 or $end2 were provided, back up the data that applies
863 # to the current date range, and store the new date range in it's place.
864
865 my ($old_start, $old_end, $old_first, $old_last);
866
867 if ($tmp_limits) {
868 $old_start = $$self{'data'}{'start'};
869 $old_end = $$self{'data'}{'end'};
870 $old_first = $$self{'data'}{'first'};
871 $old_last = $$self{'data'}{'last'};
872
873 $$self{'data'}{'start'} = $start2;
874 $$self{'data'}{'end'} = $end2;
875 $$self{'data'}{'first'} = undef;
876 $$self{'data'}{'last'} = undef;
877 }
878
879 # Get all of the dates
880
881 my($end,$first,$last,@dates);
882
883 $first = $self->_locate_n('first');
884 $last = $self->_locate_n('last');
885
886 if (defined($first) && defined($last)) {
887 for (my $n = $first; $n <= $last; $n++) {
888 my($date,$err) = $self->nth($n);
889 push(@dates,$date) if (defined $date);
890 }
891 }
892
893 # Restore the original date range values.
894
895 if ($tmp_limits) {
896 $$self{'data'}{'start'} = $old_start;
897 $$self{'data'}{'end'} = $old_end;
898 $$self{'data'}{'first'} = $old_first;
899 $$self{'data'}{'last'} = $old_last;
900 }
901
902 return @dates;
903}
904
905########################################################################
906# MISC
907########################################################################
908
909# This checks a recurrence for errors and completeness prior to
910# extracting a date or dates from it.
911#
912sub _error {
913 my($self,$range_required,$start2,$end2) = @_;
914
915 return ('Invalid recurrence') if ($self->err());
916
917 # All dates entered must be valid.
918
919 my($start,$end);
920 if (defined $start2) {
921 if (ref($start2) eq 'Date::Manip::Date') {
922 $start = $start2;
923 } elsif (! ref($start2)) {
924 $start = $self->new_date();
925 $start->parse($start2);
926 } else {
927 return ('Invalid start argument');
928 }
929 return ('Start invalid') if ($start->err());
930 } elsif (defined $$self{'data'}{'start'}) {
931 $start = $$self{'data'}{'start'};
932 return ('Start invalid') if ($start->err());
933 }
934
935 if (defined $end2) {
936 if (ref($end2) eq 'Date::Manip::Date') {
937 $end = $end2;
938 } elsif (! ref($end2)) {
939 $end = $self->new_date();
940 $end->parse($end2);
941 } else {
942 return ('Invalid end argument');
943 }
944 return ('End invalid') if ($end->err());
945 } elsif (defined $$self{'data'}{'end'}) {
946 $end = $$self{'data'}{'end'};
947 return ('End invalid') if ($end->err());
948 }
949
950 if (defined $$self{'data'}{'base'}) {
951 my $base = $$self{'data'}{'base'};
952 return ('Base invalid') if ($base->err());
953 }
954
955 # *Y:M:W:D:H:MN:S is complete.
956
957 if ($$self{'data'}{'noint'}) {
958 if ($$self{'data'}{'noint'} == 1) {
959 my @dates = $self->_apply_rtime_mods();
960 $$self{'data'}{'noint'} = 2;
961
962 my $n = 0;
963 foreach my $date (@dates) {
964 next if (! defined $date);
965 $$self{'data'}{'dates'}{$n++} = $date;
966 }
967
968 return (0,$start,$end) if ($n == 0);
969
970 if (defined $start && defined $end) {
971 my ($first,$last);
972 for (my $i=0; $i<$n; $i++) {
973 my $date = $$self{'data'}{'dates'}{$i};
974 if ($start->cmp($date) <= 0 &&
975 $end->cmp($date) >= 0) {
976 $first = $i;
977 last;
978 }
979 }
980 for (my $i=$n-1; $i>=0; $i--) {
981 my $date = $$self{'data'}{'dates'}{$i};
982 if ($start->cmp($date) <= 0 &&
983 $end->cmp($date) >= 0) {
984 $last = $i;
985 last;
986 }
987 }
988
989 $$self{'data'}{'first'} = $first;
990 $$self{'data'}{'last'} = $last;
991 } else {
992 $$self{'data'}{'first'} = 0;
993 $$self{'data'}{'last'} = $n-1;
994 }
995 }
996 return (0,$start,$end);
997 }
998
999 # If a range is entered, it must be valid. Also
1000 # a range is required if $range_required is given.
1001
1002 if ($start && $end) {
1003 return ('Range invalid') if ($start->cmp($end) == 1);
1004 } elsif ($range_required) {
1005 return ('Incomplete recurrence');
1006 }
1007
1008 # Check that the base date is available.
1009
1010 $self->_actual_base($start);
1011
1012 if (defined $$self{'data'}{'BASE'}) {
1013 my $base = $$self{'data'}{'BASE'};
1014 return ('Base invalid') if ($base->err());
1015 return (0,$start,$end);
1016 }
1017
1018 return ('Incomplete recurrence');
1019}
1020
1021# This determines the actual base date from a specified base date (or
1022# start date). If a base date cannot be set, then
1023# $$self{'data'}{'BASE'} is NOT defined.
1024#
1025sub _actual_base {
1026 my($self,$start2) = @_;
1027
1028 # Is the actual base date already defined?
1029
1030 return if (defined $$self{'data'}{'BASE'});
1031
1032 # Use the specified base date or start date.
1033
1034 my $base = undef;
1035 if (defined $$self{'data'}{'base'}) {
1036 $base = $$self{'data'}{'base'};
1037 } elsif (defined $start2) {
1038 $base = $start2;
1039 } elsif (defined $$self{'data'}{'start'}) {
1040 $base = $$self{'data'}{'start'};
1041 } else {
1042 return;
1043 }
1044
1045 # Determine the actual base date from the specified base date.
1046
1047 my $dmt = $$self{'tz'};
1048 my $dmb = $$dmt{'base'};
1049 $dmt->_update_now(); # Update NOW
1050 my @int = @{ $$self{'data'}{'interval'} };
1051 my @rtime = @{ $$self{'data'}{'rtime'} };
1052 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1053 my ($y,$m,$d,$h,$mn,$s) = $base->value();
1054 my $BASE = $self->new_date();
1055 my $n = @int;
1056
1057 if ($n == 0) {
1058 # *Y:M:W:D:H:MN:S
1059 return;
1060
1061 } elsif ($n == 1) {
1062 # Y*M:W:D:H:MN:S
1063 $BASE->set('date',[$y,1,1,0,0,0]);
1064
1065 } elsif ($n == 2) {
1066 # Y:M*W:D:H:MN:S
1067 $BASE->set('date',[$y,$m,1,0,0,0]);
1068
1069 } elsif ($n == 3) {
1070 # Y:M:W*D:H:MN:S
1071 my($yy,$w) = $dmb->week_of_year([$y,$m,$d,$h,$mn,$s]);
1072 my($ymd) = $dmb->week_of_year($yy,$w);
1073 $BASE->set('date',[@$ymd,0,0,0]);
1074
1075 } elsif ($n == 4) {
1076 # Y:M:W:D*H:MN:S
1077 $BASE->set('date',[$y,$m,$d,0,0,0]);
1078
1079 } elsif ($n == 5) {
1080 # Y:M:W:D:H*MN:S
1081 $BASE->set('date',[$y,$m,$d,$h,0,0]);
1082
1083 } elsif ($n == 6) {
1084 # Y:M:W:D:H:MN*S
1085 $BASE->set('date',[$y,$m,$d,$h,$mn,0]);
1086
1087 } else {
1088 # Y:M:W:D:H:MN:S
1089 $BASE->set('date',[$y,$m,$d,$h,$mn,$s]);
1090 }
1091
1092 $$self{'data'}{'BASE'} = $BASE;
1093}
1094
1095sub _rx {
1096 my($self,$rx) = @_;
1097 my $dmt = $$self{'tz'};
1098 my $dmb = $$dmt{'base'};
1099
1100 return $$dmb{'data'}{'rx'}{'recur'}{$rx}
1101 if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx});
1102
1103 if ($rx eq 'std') {
1104
1105 my $l = '[0-9]*';
1106 my $r = '[-,0-9]*';
1107 my $stdrx = "(?<l>$l:$l:$l:$l:$l:$l:$l)(?<r>)|" .
1108 "(?<l>$l:$l:$l:$l:$l:$l)\\*(?<r>$r)|" .
1109 "(?<l>$l:$l:$l:$l:$l)\\*(?<r>$r:$r)|" .
1110 "(?<l>$l:$l:$l:$l)\\*(?<r>$r:$r:$r)|" .
1111 "(?<l>$l:$l:$l)\\*(?<r>$r:$r:$r:$r)|" .
1112 "(?<l>$l:$l)\\*(?<r>$r:$r:$r:$r:$r)|" .
1113 "(?<l>$l)\\*(?<r>$r:$r:$r:$r:$r:$r)|" .
1114 "(?<l>)\\*(?<r>$r:$r:$r:$r:$r:$r:$r)";
1115 $$dmb{'data'}{'rx'}{'recur'}{$rx} = qr/^\s*(?:$stdrx)\s*$/;
1116
1117 } elsif ($rx eq 'rfield' ||
1118 $rx eq 'rnum' ||
1119 $rx eq 'rrange') {
1120
1121 my $num = '\-?\d+';
1122 my $range = "$num\-$num";
1123 my $val = "(?:$range|$num)";
1124 my $vals = "$val(?:,$val)*";
1125
1126 $$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/;
1127 $$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/;
1128 $$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/;
1129
1130 } elsif ($rx eq 'each') {
1131
1132 my $each = $$dmb{'data'}{'rx'}{'each'};
1133
1134 my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i;
1135 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx;
1136
1137 } elsif ($rx eq 'ignore') {
1138
1139 my $of = $$dmb{'data'}{'rx'}{'of'};
1140 my $on = $$dmb{'data'}{'rx'}{'on'};
1141
1142 my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i;
1143 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx;
1144
1145 } elsif ($rx eq 'every') {
1146
1147 my $month = $$dmb{'data'}{'rx'}{'fields'}[2];
1148 my $week = $$dmb{'data'}{'rx'}{'fields'}[3];
1149 my $day = $$dmb{'data'}{'rx'}{'fields'}[4];
1150
1151 my $last = $$dmb{'data'}{'rx'}{'last'};
1152 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
1153 my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
1154 my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0];
1155
1156 my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
1157 my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
1158 my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1159 my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0];
1160
1161 my $beg = '(?:^|\s+)';
1162 my $end = '(?:\s*$)';
1163
1164 $month = "$beg(?<month>$month)"; # months
1165 $week = "$beg(?<week>$week)"; # weeks
1166 $day = "$beg(?<day>$day)"; # days
1167
1168 $last = "$beg(?<last>$last)"; # last
1169 $nth = "$beg(?<nth>$nth)"; # 1st,2nd,...
1170 $nth_wom = "$beg(?<nth>$nth_wom)"; # 1st - 5th
1171 $nth_dom = "$beg(?<nth>$nth_dom)"; # 1st - 31st
1172 my $n = "$beg(?<n>\\d+)"; # 1,2,...
1173
1174 my $dow = "$beg(?:(?<day_name>$day_name)|(?<day_abb>$day_abb))"; # Sun|Sunday
1175 my $mmm = "$beg(?:(?<mon_name>$mon_name)|(?<mon_abb>$mon_abb))"; # Jan|January
1176
1177 my $y = "(?:$beg(?:(?<y>\\d\\d\\d\\d)|(?<y>\\d\\d)))?";
1178
1179 my $freqrx =
1180 "$nth_wom?$dow$mmm$y|" . # every DoW in MMM [YY]
1181 "$last$dow$mmm$y|" . # Nth DoW in MMM [YY]
1182 # last DoW in MMM [YY]
1183 # day_name|day_abb
1184 # mon_name|mon_abb
1185 # last*|nth*
1186 # y*
1187 "$nth_wom?$dow$month$y|" . # every DoW of every month [YY]
1188 "$last$dow$month$y|" . # Nth DoW of every month [YY]
1189 # last DoW of every month [YY]
1190 # day_name|day_abb
1191 # last*|nth*
1192 # y*
1193 "$nth_dom?$day$month$y|" . # every day of every month [YY]
1194 "$last$day$month$y|" . # Nth day of every month [YY]
1195 # last day of every month [YY]
1196 # day
1197 # month
1198 # nth*|last*
1199 # y*
1200 "$nth*$day$y|" . # every day [YY]
1201 "$n$day$y"; # every Nth day [YY]
1202 # every N days [YY]
1203 # day
1204 # nth*|n*
1205 # y*
1206
1207 $freqrx = qr/^(?:$freqrx)\s*$/i;
1208 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx;
1209 }
1210
1211 return $$dmb{'data'}{'rx'}{'recur'}{$rx};
1212}
1213
1214# @dates = $self->_apply_rtime_mods();
1215#
1216# Should only be called if there is no interval (*Y:M:W:D:H:MN:S).
1217#
1218# It will use rtime/modifiers to get a list of all events
1219# specified by the recurrence. This only needs to be done once.
1220#
1221# @dates = $self->_apply_rtime_mods($date);
1222#
1223# For all other types of recurrences, this will take a single
1224# date and apply all rtime/modifiers to it to get a list of
1225# events.
1226#
1227sub _apply_rtime_mods {
1228 my($self,$date) = @_;
1229 my $dmt = $$self{'tz'};
1230 my $dmb = $$dmt{'base'};
1231 my @int = @{ $$self{'data'}{'interval'} };
1232 my @rtime = @{ $$self{'data'}{'rtime'} };
1233 my $n = @int;
1234
1235 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1236 my $m_empty = $self->_field_empty($mf);
1237 my $w_empty = $self->_field_empty($wf);
1238 my $d_empty = $self->_field_empty($df);
1239 my ($err,$y,$m,$d,$h,$mn,$s,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n);
1240 ($y,$m,$d,$h,$mn,$s) = $date->value() if (defined $date);
1241 my(@date);
1242
1243 if ($n <= 1) {
1244 #
1245 # *Y:M:W:D:H:MN:S
1246 # Y*M:W:D:H:MN:S
1247 #
1248
1249 if (@int == 0) {
1250 ($err,@y) = $self->_rtime_values('y',$yf);
1251 return () if ($err);
1252 } else {
1253 @y = ($y);
1254 }
1255
1256 if ( ($m_empty && $w_empty && $d_empty) ||
1257 (! $m_empty && $w_empty) ) {
1258
1259 # *0:0:0:0 Jan 1 of the current year
1260 # *1:0:0:0 Jan 1, 0001
1261 # *0:2:0:0 Feb 1 of the current year
1262 # *1:2:0:0 Feb 1, 0001
1263 # *0:2:0:4 Feb 4th of the current year
1264 # *1:2:0:4 Feb 4th, 0001
1265 # 1*0:0:0 every year on Jan 1
1266 # 1*2:0:0 every year on Feb 1
1267 # 1*2:0:4 every year on Feb 4th
1268
1269 $mf = [1] if ($m_empty);
1270 $df = [1] if ($d_empty);
1271
1272 ($err,@m) = $self->_rtime_values('m',$mf);
1273 return () if ($err);
1274
1275 foreach my $y (@y) {
1276 foreach my $m (@m) {
1277 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1278 return () if ($err);
1279 foreach my $d (@d) {
1280 push(@date,[$y,$m,$d,0,0,0]);
1281 }
1282 }
1283 }
1284
1285 } elsif ($m_empty) {
1286
1287 if ($w_empty) {
1288
1289 # *0:0:0:4 the 4th day of the current year
1290 # *1:0:0:4 the 4th day of 0001
1291 # 1*0:0:4 every year on the 4th day of the year
1292
1293 foreach my $y (@y) {
1294 ($err,@doy) = $self->_rtime_values('day_of_year',$df,$y);
1295 return () if ($err);
1296 foreach my $doy (@doy) {
1297 my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) };
1298 push(@date,[$yy,$mm,$dd,0,0,0]);
1299 }
1300 }
1301
1302 } elsif ($d_empty) {
1303
1304 # *0:0:3:0 the first day of the 3rd week of the curr year
1305 # *1:0:3:0 the first day of the 3rd week of 0001
1306 # 1*0:3:0 every year on the first day of 3rd week of year
1307
1308 foreach my $y (@y) {
1309 ($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y);
1310 return () if ($err);
1311 foreach my $woy (@woy) {
1312 my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) };
1313 push(@date,[$yy,$mm,$dd,0,0,0]);
1314 }
1315 }
1316
1317 } else {
1318
1319 # *1:0:3:4 in 0001 on the 3rd Thur of the year
1320 # *0:0:3:4 on the 3rd Thur of the current year
1321 # 1*0:3:4 every year on the 3rd Thur of the year
1322
1323 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1324 return () if ($err);
1325 foreach my $y (@y) {
1326 foreach my $dow (@dow) {
1327 ($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow);
1328 return () if ($err);
1329 foreach my $n (@n) {
1330 my $ymd = $dmb->nth_day_of_week($y,$n,$dow);
1331 my($yy,$mm,$dd) = @$ymd;
1332 push(@date,[$yy,$mm,$dd,0,0,0]);
1333 }
1334 }
1335 }
1336 }
1337
1338 } else {
1339
1340 # *1:2:3:4 in Feb 0001 on the 3rd Thur of the month
1341 # *0:2:3:4 on the 3rd Thur of Feb in the curr year
1342 # *1:2:3:0 the 3rd occurence of FirstDay in Feb 0001
1343 # *0:2:3:0 the 3rd occurence of FirstDay in Feb of curr year
1344 # 1*2:3:4 every year in Feb on the 3rd Thur
1345 # 1*2:3:0 every year on the 3rd occurence of FirstDay in Feb
1346
1347 ($err,@m) = $self->_rtime_values('m',$mf);
1348 return () if ($err);
1349
1350 if ($d_empty) {
1351 @dow = ($dmb->_config('firstday'));
1352 } else {
1353 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1354 return () if ($err);
1355 }
1356
1357 foreach my $y (@y) {
1358 foreach my $m (@m) {
1359 foreach my $dow (@dow) {
1360 ($err,@n) = $self->_rtime_values('dow_of_month',
1361 $wf,$y,$m,$dow);
1362 return () if ($err);
1363 foreach my $n (@n) {
1364 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1365 my($yy,$mm,$dd) = @$ymd;
1366 push(@date,[$yy,$mm,$dd,0,0,0]);
1367 }
1368 }
1369 }
1370 }
1371 }
1372
1373 } elsif ($n == 2) {
1374
1375 #
1376 # Y:M*W:D:H:MN:S
1377 #
1378
1379 if ($w_empty) {
1380
1381 # 0:2*0:0 every 2 months on the first day of the month
1382 # 0:2*0:4 every 2 months on the 4th day of the month
1383 # 1:2*0:0 every 1 year, 2 months on the first day of the month
1384 # 1:2*0:4 every 1 year, 2 months on the 4th day of the month
1385
1386 $df = [1] if ($d_empty);
1387
1388 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1389 return () if ($err);
1390 foreach my $d (@d) {
1391 push(@date,[$y,$m,$d,0,0,0]);
1392 }
1393
1394 } else {
1395
1396 # 0:2*3:0 every 2 months on the 3rd occurence of FirstDay
1397 # 0:2*3:4 every 2 months on the 3rd Thur of the month
1398 # 1:2*3:0 every 1 year, 2 months on 3rd occurence of FirstDay
1399 # 1:2*3:4 every 1 year, 2 months on the 3rd Thur of the month
1400
1401 if ($d_empty) {
1402 @dow = ($dmb->_config('firstday'));
1403 } else {
1404 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1405 return () if ($err);
1406 }
1407
1408 foreach my $dow (@dow) {
1409 ($err,@n) = $self->_rtime_values('dow_of_month',
1410 $wf,$y,$m,$dow);
1411 return () if ($err);
1412 foreach my $n (@n) {
1413 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1414 my($yy,$mm,$dd) = @$ymd;
1415 push(@date,[$yy,$mm,$dd,0,0,0]);
1416 }
1417 }
1418 }
1419
1420 } elsif ($n == 3) {
1421
1422 #
1423 # Y:M:W*D:H:MN:S
1424 #
1425
1426 # 0:0:3*0 every 3 weeks on FirstDay
1427 # 0:0:3*4 every 3 weeks on Thur
1428 # 0:2:3*0 every 2 months, 3 weeks on FirstDay
1429 # 0:2:3*4 every 2 months, 3 weeks on Thur
1430 # 1:0:3*0 every 1 year, 3 weeks on FirstDay
1431 # 1:0:3*4 every 1 year, 3 weeks on Thur
1432 # 1:2:3*0 every 1 year, 2 months, 3 weeks on FirstDay
1433 # 1:2:3*4 every 1 year, 2 months, 3 weeks on Thur
1434
1435 my $fdow = $dmb->_config('firstday');
1436 if ($d_empty) {
1437 @dow = ($fdow);
1438 } else {
1439 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1440 return () if ($err);
1441 }
1442
1443 my($mm,$dd);
1444 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]);
1445 ($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) };
1446
1447 foreach my $dow (@dow) {
1448 $dow += 7 if ($dow < $fdow);
1449 my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) };
1450 push(@date,[$yyy,$mmm,$ddd,0,0,0]);
1451 }
1452
1453 } elsif ($n == 4) {
1454
1455 #
1456 # Y:M:W:D*H:MN:S
1457 #
1458
1459 push(@date,[$y,$m,$d,0,0,0]);
1460
1461 } elsif ($n == 5) {
1462
1463 #
1464 # Y:M:W:D:H*MN:S
1465 #
1466
1467 push(@date,[$y,$m,$d,$h,0,0]);
1468
1469 } elsif ($n == 6) {
1470
1471 #
1472 # Y:M:W:D:H:MN*S
1473 #
1474
1475 push(@date,[$y,$m,$d,$h,$mn,0]);
1476
1477 } elsif ($n == 7) {
1478
1479 #
1480 # Y:M:W:D:H:MN:S
1481 #
1482
1483 push(@date,[$y,$m,$d,$h,$mn,$s]);
1484 }
1485
1486 #
1487 # Handle the H/MN/S portion.
1488 #
1489
1490 # Do hours
1491 if ($n <= 4 ) {
1492 ($err,@h) = $self->_rtime_values('h',$hf);
1493 return () if ($err);
1494 $self->_field_add_values(\@date,3,@h);
1495 }
1496
1497 # Do minutes
1498 if ($n <= 5) {
1499 ($err,@mn) = $self->_rtime_values('mn',$mnf);
1500 return () if ($err);
1501 $self->_field_add_values(\@date,4,@mn);
1502 }
1503
1504 # Do seconds
1505 if ($n <= 6) {
1506 ($err,@s) = $self->_rtime_values('s',$sf);
1507 return () if ($err);
1508 $self->_field_add_values(\@date,5,@s);
1509 }
1510
1511 # Sort the dates... just to be sure.
1512
1513 @date = sort { $dmb->cmp($a,$b) } @date if (@date);
1514
1515 #
1516 # Apply modifiers
1517 #
1518
1519 my @flags = @{ $$self{'data'}{'flags'} };
1520 if (@flags) {
1521 my $obj = $self->new_date();
1522
1523 my @keep;
1524 foreach my $date (@date) {
1525 my ($y,$m,$d,$h,$mn,$s) = @$date;
1526
1527 my $keep = 1;
1528
1529 MODIFIER:
1530 foreach my $flag (@flags) {
1531 my(@wd,$today);
1532
1533 if ($flag =~ /^([pn])([dt])([1-7])$/) {
1534 my($forw,$today,$dow) = ($1,$2,$3);
1535 $forw = ($forw eq 'p' ? 0 : 1);
1536 $today = ($today eq 'd' ? 0 : 1);
1537 ($y,$m,$d,$h,$mn,$s) =
1538 @{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) };
1539
1540 } elsif ($flag =~ /^([fb])([dw])(\d+)$/) {
1541 my($prev,$business,$n) = ($1,$2,$3);
1542 $prev = ($prev eq 'b' ? 1 : 0);
1543 $business = ($business eq 'w' ? 1 : 0);
1544
1545 if ($business) {
1546 ($y,$m,$d,$h,$mn,$s) =
1547 @{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) };
1548 } else {
1549 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) };
1550 }
1551
1552 } elsif ($flag eq 'ibd' ||
1553 $flag eq 'nbd') {
1554 my $bd = $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0);
1555
1556 if ( ($flag eq 'ibd' && ! $bd) ||
1557 ($flag eq 'nbd' && $bd) ) {
1558 $keep = 0;
1559 last MODIFIER;
1560 }
1561
1562 } elsif ($flag =~ /^wd(\d)$/) {
1563 my $dow = $1; # Dow wanted
1564 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1565 if ($dow != $currdow) {
1566 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]); # What week is this
1567 my $tmp = $dmb->week_of_year($yy,$ww); # First day of week
1568 ($y,$m,$d) = @$tmp;
1569 $currdow = $dmb->_config('firstday');
1570 if ($dow > $currdow) {
1571 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow);
1572 ($y,$m,$d) = @$tmp;
1573 } elsif ($dow < $currdow) {
1574 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow+7);
1575 ($y,$m,$d) = @$tmp;
1576 }
1577 }
1578
1579 } elsif ($flag eq 'nwd') {
1580 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1581 ($y,$m,$d,$h,$mn,$s) =
1582 @{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) };
1583 }
1584
1585 } elsif ($flag eq 'pwd') {
1586 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1587 ($y,$m,$d,$h,$mn,$s) =
1588 @{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) };
1589 }
1590
1591 } elsif ($flag eq 'easter') {
1592 ($m,$d) = $self->_easter($y);
1593
1594 } elsif ($flag eq 'dwd' &&
1595 $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1596 # nothing
1597
1598 } else {
1599
1600 if ($flag eq 'cwd' || $flag eq 'dwd') {
1601 if ($dmb->_config('tomorrowfirst')) {
1602 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1603 } else {
1604 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1605 }
1606
1607 } elsif ($flag eq 'cwn') {
1608 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1609 $today = 0;
1610
1611 } elsif ($flag eq 'cwp') {
1612 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1613 $today = 0;
1614 }
1615
1616 while (1) {
1617 my(@d,$off);
1618
1619 # Test in the first direction
1620
1621 @d = @{ $wd[0] };
1622 $off = $wd[1];
1623 @d = @{ $dmb->calc_date_days(\@d,$off) };
1624
1625 if ($obj->__is_business_day(\@d,0)) {
1626 ($y,$m,$d,$h,$mn,$s) = @d;
1627 last;
1628 }
1629
1630 $wd[0] = [@d];
1631
1632 # Test in the other direction
1633
1634 @d = @{ $wd[2] };
1635 $off = $wd[3];
1636 @d = @{ $dmb->calc_date_days(\@d,$off) };
1637
1638 if ($obj->__is_business_day(\@d,0)) {
1639 ($y,$m,$d,$h,$mn,$s) = @d;
1640 last;
1641 }
1642
1643 $wd[2] = [@d];
1644 }
1645
1646 }
1647 }
1648
1649 if ($keep) {
1650 push(@keep,[$y,$m,$d,$h,$mn,$s]);
1651 }
1652 }
1653 @date = @keep;
1654 }
1655
1656 #
1657 # Convert the dates to objects.
1658 #
1659
1660 my(@ret);
1661
1662 foreach my $date (@date) {
1663 my @d = @$date;
1664
1665 my $obj = $self->new_date();
1666 $obj->set('date',\@d);
1667 if ($obj->err()) {
1668 push(@ret,undef);
1669 } else {
1670 push(@ret,$obj);
1671 }
1672 }
1673
1674 return @ret;
1675}
1676
1677# This calculates the Nth interval date (0 is the base date) and then
1678# calculates the recurring events produced by it.
1679#
1680sub _nth_interval {
1681 my($self,$n) = @_;
1682 return if (exists $$self{'data'}{'idate'}{$n});
1683 my $base = $$self{'data'}{'BASE'};
1684 my $date;
1685
1686 # Get the interval date.
1687
1688 if ($n == 0) {
1689 $date = $base;
1690
1691 } else {
1692 my @delta = $$self{'data'}{'delta'}->value;
1693 my $absn = abs($n);
1694 @delta = map { $absn*$_ } @delta;
1695 my $delta = $self->new_delta;
1696 $delta->set('delta',[@delta]);
1697 $date = $base->calc($delta, ($n>0 ? 0 : 2));
1698 }
1699
1700 # For 'slow' recursion, we need to make sure we've got
1701 # the n-1 or n+1 interval as appropriate.
1702
1703 if ($$self{'data'}{'slow'}) {
1704
1705 if ($n > 0) {
1706 $self->_nth_interval($n-1);
1707 } elsif ($n < 0) {
1708 $self->_nth_interval($n+1);
1709 }
1710 }
1711
1712 # Get the list of events associated with this interval date.
1713
1714 my @date = $self->_apply_rtime_mods($date);
1715
1716 # Determine the index of the earliest event associated with
1717 # this interval date.
1718 #
1719 # Events are numbered [$n0...$n1]
1720
1721 my($n0,$n1);
1722 if ($$self{'data'}{'slow'}) {
1723
1724 if ($n == 0) {
1725 $n0 = 0;
1726 $n1 = $#date;
1727
1728 } elsif ($n > 0) {
1729 $n0 = $$self{'data'}{'idate'}{$n-1}[2] + 1;
1730 $n1 = $n0 + $#date;
1731
1732 } else {
1733 $n1 = $$self{'data'}{'idate'}{$n+1}[1] - 1;
1734 $n0 = $n1 - $#date;
1735 }
1736
1737 } else {
1738
1739 # ev_per_d = 3
1740 # idate = 0 1 2
1741 # events = 0 1 2 3 4 5 6 7 8
1742
1743 # ev_per_d = 3
1744 # idate = -1 -2 -3
1745 # events = -3 -2 -1 -6 -5 -4 -9 -8 -7
1746
1747 $n0 = $n * $$self{'data'}{'ev_per_d'};
1748 $n1 = $n0 + $$self{'data'}{'ev_per_d'} - 1;
1749 }
1750
1751 # Store the dates.
1752
1753 for (my $i=0; $i<=$#date; $i++) {
1754 $$self{'data'}{'dates'}{$n0+$i} = $date[$i];
1755 }
1756
1757 # Store the idate.
1758
1759 if ($$self{'data'}{'slow'}) {
1760 $$self{'data'}{'idate'}{$n} = [$date,$n0,$n1];
1761 } else {
1762 $$self{'data'}{'idate'}{$n} = $date;
1763 }
1764}
1765
1766# This locates the first/last event in the range and returns $n. It
1767# returns undef if there is no date in the range.
1768#
1769sub _locate_n {
1770 my($self,$op) = @_;
1771
1772 return $$self{'data'}{$op} if (defined $$self{'data'}{$op} ||
1773 $$self{'data'}{'noint'} == 2);
1774
1775 my ($first,$last);
1776 my $start = $$self{'data'}{'start'};
1777 my $end = $$self{'data'}{'end'};
1778
1779 #
1780 # For a 'slow' recurrence, we'll get both the start and the end at
1781 # once by starting at n=0 and working forwards or backwards.
1782 #
1783
1784 if ($$self{'data'}{'slow'}) {
1785
1786 if ($$self{'data'}{'holiday'}) {
1787 # Move backwards until date <= start
1788 # Then move forwards until date >= start
1789 #
1790 # Then move forwards until we have a date > end
1791 #
1792 # We want:
1793 # start <= date(first) <= date(last) <= end
1794
1795 my($date,$first,$last);
1796 $first = 0;
1797 while (1) {
1798 $self->_nth_interval($first);
1799 $date = $$self{'data'}{'idate'}{$first}[0];
1800 last if (defined $date && $date->cmp($start) <= 0);
1801 $first--;
1802 }
1803 while (1) {
1804 $self->_nth_interval($first);
1805 $date = $$self{'data'}{'idate'}{$first}[0];
1806 last if (defined $date && $date->cmp($start) >= 0);
1807 $first++;
1808 }
1809
1810 return undef if ($date->cmp($end) == 1);
1811 $last = $first;
1812
1813 while (1) {
1814 $self->_nth_interval($last);
1815 $date = $$self{'data'}{'idate'}{$last}[0];
1816 last if (defined $date && $date->cmp($end) == 1);
1817 $last++;
1818 }
1819 $last--;
1820
1821 $first = $$self{'data'}{'idate'}{$first}[1];
1822 $last = $$self{'data'}{'idate'}{$last}[2];
1823
1824 } else {
1825 # Move backwards until date <= start
1826 # Then move forwards until date >= start
1827 #
1828 # Then move forwards until we have date > end
1829 #
1830 # We want:
1831 # start <= date(first) <= date(last) <= end
1832
1833 my($date,$err);
1834 $first = 0;
1835 while (1) {
1836 ($date,$err) = $self->nth($first);
1837 last if (defined $date && $date->cmp($start) <= 0);
1838 $first--;
1839 }
1840 while (1) {
1841 ($date,$err) = $self->nth($first);
1842 last if (defined $date && $date->cmp($start) >= 0);
1843 $first++;
1844 }
1845
1846 return undef if ($date->cmp($end) == 1);
1847 $last = $first;
1848
1849 while (1) {
1850 ($date,$err) = $self->nth($last);
1851 last if (defined $date && $date->cmp($end) == 1);
1852 $last++;
1853 }
1854 $last--;
1855 }
1856
1857 return undef if ($last < $first);
1858 $$self{'data'}{'first'} = $first;
1859 $$self{'data'}{'last'} = $last;
1860 return $$self{'data'}{$op}
1861 }
1862
1863 #
1864 # For a regular recurrence, we can estimate which interval date we're
1865 # interested in and then move forward/backward from it.
1866 #
1867 #
1868 # Calculate the interval date index ($nn) based on the length of
1869 # the delta.
1870 #
1871
1872 my $base = $$self{'data'}{'BASE'};
1873 my $delta = $$self{'data'}{'delta'};
1874 # $len = 0 is when a recur contains no delta (i.e. *Y:M:W:D:H:Mn:S)
1875 my $len = ($delta ? $delta->printf('%sys') : 0);
1876
1877 my $targ = ($op eq 'first' ? $start : $end);
1878 my $diff = $base->calc($targ);
1879 my $tot = $diff->printf('%sys');
1880 my $nn = ($len ? int($tot/$len) : 1);
1881 my $n = $nn*$$self{'data'}{'ev_per_d'};
1882
1883 #
1884 # For a holiday, find the NNth interval date.
1885 #
1886
1887 my($date);
1888
1889 if ($$self{'data'}{'holiday'}) {
1890
1891 # Move backwards until we have date <= target
1892 # Move forward until we have date >= target (after)
1893 # Move backarad again until we have date <= target (before)
1894
1895 my($beforenn,$afternn);
1896 $afternn = $nn;
1897
1898 while (1) {
1899 $self->_nth_interval($afternn);
1900 $date = $$self{'data'}{'idate'}{$afternn}[0];
1901 last if (defined $date && $date->cmp($targ) <= 0);
1902 $afternn--;
1903 }
1904 while (1) {
1905 $self->_nth_interval($afternn);
1906 $date = $$self{'data'}{'idate'}{$afternn}[0];
1907 last if (defined $date && $date->cmp($targ) >= 0);
1908 $afternn++;
1909 }
1910 $beforenn = $afternn;
1911 while (1) {
1912 $self->_nth_interval($beforenn);
1913 $date = $$self{'data'}{'idate'}{$beforenn}[0];
1914 last if (defined $date && $date->cmp($targ) <= 0);
1915 $beforenn--;
1916 }
1917 return undef if ($afternn < $beforenn);
1918
1919 # If we're looking for the first date, it's the afternn
1920 # date. Otherwise, it's the beforenn one.
1921
1922 if ($op eq 'first') {
1923 $n = $afternn*$$self{'data'}{'ev_per_d'};
1924 } else {
1925 $n = ($beforenn+1)*$$self{'data'}{'ev_per_d'}-1;
1926 }
1927
1928 $$self{'data'}{$op} = $n;
1929 return $$self{'data'}{$op}
1930 }
1931
1932 #
1933 # For a regular recurrence, find the Nth date.
1934 #
1935
1936 # Move backwards until we have date <= target
1937 # Move forward until we have date >= target (after)
1938 # Move backarad again until we have date <= target (before)
1939
1940 my($beforen,$aftern,$before,$after,$err);
1941 $aftern = $n;
1942
1943 while (1) {
1944 ($after,$err) = $self->nth($aftern);
1945 return undef if ($err);
1946 last if (defined $after && $after->cmp($targ) <= 0);
1947 $aftern--;
1948 }
1949 while (1) {
1950 ($after,$err) = $self->nth($aftern);
1951 return undef if ($err);
1952 last if (defined $after && $after->cmp($targ) >= 0);
1953 $aftern++;
1954 }
1955 $beforen = $aftern;
1956 while (1) {
1957 ($before,$err) = $self->nth($beforen);
1958 return undef if ($err);
1959 last if (defined $before && $before->cmp($targ) <= 0);
1960 $beforen--;
1961 }
1962 return undef if ($aftern < $beforen);
1963
1964 if ($op eq 'first') {
1965 $$self{'data'}{$op} = $aftern;
1966 return $aftern;
1967 } else {
1968 $$self{'data'}{$op} = $beforen;
1969 return $beforen;
1970 }
1971}
1972
1973# This returns the date easter occurs on for a given year as ($month,$day).
1974# This is from the Calendar FAQ.
1975#
1976sub _easter {
1977 my($self,$y) = @_;
1978
1979 my($c) = $y/100;
1980 my($g) = $y % 19;
1981 my($k) = ($c-17)/25;
1982 my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30;
1983 $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11));
1984 my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
1985 my($l) = $i-$j;
1986 my($m) = 3 + ($l+40)/44;
1987 my($d) = $l + 28 - 31*($m/4);
1988 return ($m,$d);
1989}
1990
1991# This returns 1 if a field is empty.
1992#
1993sub _field_empty {
1994 my($self,$val) = @_;
1995
1996 if (ref($val)) {
1997 my @tmp = @$val;
1998 return 1 if ($#tmp == -1 ||
1999 ($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0]));
2000 return 0;
2001
2002 } else {
2003 return $val;
2004 }
2005}
2006
2007# This returns a list of values that appear in a field in the rtime.
2008#
2009# $val is a listref, with each element being a value or a range.
2010#
2011# Usage:
2012# _rtime_values('y' ,$y);
2013# _rtime_values('m' ,$m);
2014# _rtime_values('week_of_year' ,$w ,$y);
2015# _rtime_values('dow_of_year' ,$w ,$y,$dow);
2016# _rtime_values('dow_of_month' ,$w ,$y,$m,$dow);
2017# _rtime_values('day_of_year' ,$d ,$y);
2018# _rtime_values('day_of_month' ,$d ,$y,$m);
2019# _rtime_values('day_of_week' ,$d);
2020# _rtime_values('h' ,$h);
2021# _rtime_values('mn' ,$mn);
2022# _rtime_values('s' ,$s);
2023#
2024# Returns ($err,@vals)
2025#
2026sub _rtime_values {
2027 my($self,$type,$val,@args) = @_;
2028 my $dmt = $$self{'tz'};
2029 my $dmb = $$dmt{'base'};
2030
2031 if ($type eq 'h') {
2032 @args = (0,0,23,23);
2033
2034 } elsif ($type eq 'mn') {
2035 @args = (0,0,59,59);
2036
2037 } elsif ($type eq 's') {
2038 @args = (0,0,59,59);
2039
2040 } elsif ($type eq 'y') {
2041 my $curry = $dmt->_now('y',1);
2042 foreach my $y (@$val) {
2043 $y = $curry if (! ref($y) && $y==0);
2044 }
2045
2046 @args = (0,1,9999,9999);
2047
2048 } elsif ($type eq 'm') {
2049 @args = (0,1,12,12);
2050
2051 } elsif ($type eq 'week_of_year') {
2052 my($y) = @args;
2053 my $wiy = $dmb->weeks_in_year($y);
2054 @args = (1,1,$wiy,53);
2055
2056 } elsif ($type eq 'dow_of_year') {
2057 my($y,$dow) = @args;
2058
2059 # Get the 1st occurence of $dow
2060 my $d0 = 1;
2061 my $dow0 = $dmb->day_of_week([$y,1,$d0]);
2062 if ($dow > $dow0) {
2063 $d0 += ($dow-$dow0);
2064 } elsif ($dow < $dow0) {
2065 $d0 += 7-($dow0-$dow);
2066 }
2067
2068 # Get the last occurrence of $dow
2069 my $d1 = 31;
2070 my $dow1 = $dmb->day_of_week([$y,12,$d1]);
2071 if ($dow1 > $dow) {
2072 $d1 -= ($dow1-$dow);
2073 } elsif ($dow1 < $dow) {
2074 $d1 -= 7-($dow-$dow1);
2075 }
2076
2077 # Find out the number of occurrenced of $dow
2078 my $doy1 = $dmb->day_of_year([$y,12,$d1]);
2079 my $n = ($doy1 - $d0)/7 + 1;
2080
2081 # Get the list of @w
2082 @args = (1,1,$n,53);
2083
2084 } elsif ($type eq 'dow_of_month') {
2085 my($y,$m,$dow) = @args;
2086
2087 # Get the 1st occurence of $dow in the month
2088 my $d0 = 1;
2089 my $dow0 = $dmb->day_of_week([$y,$m,$d0]);
2090 if ($dow > $dow0) {
2091 $d0 += ($dow-$dow0);
2092 } elsif ($dow < $dow0) {
2093 $d0 += 7-($dow0-$dow);
2094 }
2095
2096 # Get the last occurrence of $dow
2097 my $d1 = $dmb->days_in_month($y,$m);
2098 my $dow1 = $dmb->day_of_week([$y,$m,$d1]);
2099 if ($dow1 > $dow) {
2100 $d1 -= ($dow1-$dow);
2101 } elsif ($dow1 < $dow) {
2102 $d1 -= 7-($dow-$dow1);
2103 }
2104
2105 # Find out the number of occurrenced of $dow
2106 my $n = ($d1 - $d0)/7 + 1;
2107
2108 # Get the list of @w
2109 @args = (1,1,$n,5);
2110
2111 } elsif ($type eq 'day_of_year') {
2112 my($y) = @args;
2113 my $diy = $dmb->days_in_year($y);
2114 @args = (1,1,$diy,366);
2115
2116 } elsif ($type eq 'day_of_month') {
2117 my($y,$m) = @args;
2118 my $dim = $dmb->days_in_month($y,$m);
2119 @args = (1,1,$dim,31);
2120
2121 } elsif ($type eq 'day_of_week') {
2122 @args = (0,1,7,7);
2123 }
2124
2125 my($err,@vals) = $self->__rtime_values($val,@args);
2126 if ($err) {
2127 $$self{'err'} = "[dates] $err [$type]";
2128 return (1);
2129 }
2130 return(0,@vals);
2131}
2132
2133# This returns the raw values for a list.
2134#
2135# If $allowneg is 0, only positive numbers are allowed, and they must be
2136# in the range [$min,$absmax]. If $allowneg is 1, positive numbers in the
2137# range [$min,$absmax] and negative numbers in the range [-$absmax,-$min]
2138# are allowed. An error occurs if a value falls outside the range.
2139#
2140# Only values in the range of [$min,$max] are actually kept. This allows
2141# a recurrence for day_of_month to be 1-31 and not fail for a month that
2142# has fewer than 31 days. Any value outside the [$min,$max] are silently
2143# discarded.
2144#
2145# Returns:
2146# ($err,@vals)
2147#
2148sub __rtime_values {
2149 my($self,$vals,$allowneg,$min,$max,$absmax) = @_;
2150 my(@ret);
2151
2152 foreach my $val (@$vals) {
2153
2154 if (ref($val)) {
2155 my($val1,$val2) = @$val;
2156
2157 if ($allowneg) {
2158 return ('Value outside range')
2159 if ( ($val1 >= 0 && ($val1 < $min || $val1 > $absmax) ) ||
2160 ($val2 >= 0 && ($val2 < $min || $val2 > $absmax) ) );
2161 return ('Negative value outside range')
2162 if ( ($val1 <= 0 && ($val1 < -$absmax || $val1 > -$min) ) ||
2163 ($val2 <= 0 && ($val2 < -$absmax || $val2 > -$min) ) );
2164
2165 } else {
2166 return ('Value outside range')
2167 if ( ($val1 < $min || $val1 > $absmax) ||
2168 ($val2 < $min || $val2 > $absmax) );
2169
2170 }
2171
2172 return ('Range values reversed')
2173 if ( ($val1 <= 0 && $val2 <= 0 && $val1 > $val2) ||
2174 ($val1 >= 0 && $val2 >= 0 && $val1 > $val2) );
2175
2176 # Use $max instead of $absmax when converting negative numbers to
2177 # positive ones.
2178
2179 $val1 = $max + $val1 + 1 if ($val1 < 0); # day -10
2180 $val2 = $max + $val2 + 1 if ($val2 < 0);
2181
2182 $val1 = $min if ($val1 < $min); # day -31 in a 30 day month
2183 $val2 = $max if ($val2 > $max);
2184
2185 next if ($val1 > $val2);
2186
2187 push(@ret,$val1..$val2);
2188
2189 } else {
2190
2191 if ($allowneg) {
2192 return ('Value outside range')
2193 if ($val >= 0 && ($val < $min || $val > $absmax));
2194 return ('Negative value outside range')
2195 if ($val <= 0 && ($val < -$absmax || $val > -$min));
2196 } else {
2197 return ('Value outside range')
2198 if ($val < $min || $val > $absmax);
2199 }
2200
2201 # Use $max instead of $absmax when converting negative numbers to
2202 # positive ones.
2203
2204 my $ret;
2205 if ($val < 0 ) {
2206 $ret = $max + $val + 1;
2207 } else {
2208 $ret = $val;
2209 }
2210
2211 next if ($ret > $max || $ret < $min);
2212 push(@ret,$ret);
2213 }
2214 }
2215
2216 return ('',@ret);
2217}
2218
2219# This takes a list of dates (each a listref of [y,m,d,h,mn,s]) and replaces
2220# the Nth field with all of the possible values passed in, creating a new
2221# list with all the dates.
2222#
2223sub _field_add_values {
2224 my($self,$datesref,$n,@val) = @_;
2225
2226 my @dates = @$datesref;
2227 my @tmp;
2228
2229 foreach my $date (@dates) {
2230 my @d = @$date;
2231 foreach my $val (@val) {
2232 $d[$n] = $val;
2233 push(@tmp,[@d]);
2234 }
2235 }
2236
2237 @$datesref = @tmp;
2238}
2239
224014µs1;
2241# Local Variables:
2242# mode: cperl
2243# indent-tabs-mode: nil
2244# cperl-indent-level: 3
2245# cperl-continued-statement-offset: 2
2246# cperl-continued-brace-offset: 0
2247# cperl-brace-offset: 0
2248# cperl-brace-imaginary-offset: 0
2249# cperl-label-offset: 0
2250# End:
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.