← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:11:50 2013

Filename/usr/share/perl5/Date/Manip/Recur.pm
StatementsExecuted 41 statements in 16.2ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11131µs43µsDate::Manip::Recur::::_initDate::Manip::Recur::_init
11131µs36µsDate::Manip::Recur::::BEGIN@14Date::Manip::Recur::BEGIN@14
11127µs354µsDate::Manip::Recur::::BEGIN@20Date::Manip::Recur::BEGIN@20
11123µs38µsDate::Manip::Recur::::BEGIN@21Date::Manip::Recur::BEGIN@21
11118µs68µsDate::Manip::Recur::::BEGIN@25Date::Manip::Recur::BEGIN@25
11117µs91µsDate::Manip::Recur::::BEGIN@17Date::Manip::Recur::BEGIN@17
11116µs20µsDate::Manip::Recur::::BEGIN@22Date::Manip::Recur::BEGIN@22
11116µs21µsDate::Manip::Recur::::BEGIN@19Date::Manip::Recur::BEGIN@19
11113µs38µsDate::Manip::Recur::::BEGIN@18Date::Manip::Recur::BEGIN@18
0000s0sDate::Manip::Recur::::__rtime_valuesDate::Manip::Recur::__rtime_values
0000s0sDate::Manip::Recur::::_dateDate::Manip::Recur::_date
0000s0sDate::Manip::Recur::::_easterDate::Manip::Recur::_easter
0000s0sDate::Manip::Recur::::_field_add_valuesDate::Manip::Recur::_field_add_values
0000s0sDate::Manip::Recur::::_field_emptyDate::Manip::Recur::_field_empty
0000s0sDate::Manip::Recur::::_init_argsDate::Manip::Recur::_init_args
0000s0sDate::Manip::Recur::::_int_valuesDate::Manip::Recur::_int_values
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::::baseDate::Manip::Recur::base
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::::parseDate::Manip::Recur::parse
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
0191µsProfile data that couldn't be associated with a specific line:
# spent 91µs making 1 call to Date::Manip::Recur::BEGIN@17
118µspackage Date::Manip::Recur;
2# Copyright (c) 1998-2010 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
14359µs240µs
# spent 36µs (31+5) within Date::Manip::Recur::BEGIN@14 which was called: # once (31µs+5µs) by Date::Manip::Obj::new_recur at line 14
use Date::Manip::Obj;
# spent 36µs making 1 call to Date::Manip::Recur::BEGIN@14 # spent 5µs making 1 call to UNIVERSAL::import
15126µs@ISA = ('Date::Manip::Obj');
16
17485µs174µs
# spent 91µs (17+74) within Date::Manip::Recur::BEGIN@17 which was called: # once (17µs+74µs) by Date::Manip::Obj::new_recur at line 0
require 5.010000;
# spent 74µs making 1 call to feature::import
18330µs263µs
# spent 38µs (13+25) within Date::Manip::Recur::BEGIN@18 which was called: # once (13µs+25µs) by Date::Manip::Obj::new_recur at line 18
use warnings;
# spent 38µs making 1 call to Date::Manip::Recur::BEGIN@18 # spent 25µs making 1 call to warnings::import
19351µs226µs
# spent 21µs (16+5) within Date::Manip::Recur::BEGIN@19 which was called: # once (16µs+5µs) by Date::Manip::Obj::new_recur at line 19
use strict;
# spent 21µs making 1 call to Date::Manip::Recur::BEGIN@19 # spent 5µs making 1 call to strict::import
20366µs2680µs
# spent 354µs (27+327) within Date::Manip::Recur::BEGIN@20 which was called: # once (27µs+327µs) by Date::Manip::Obj::new_recur at line 20
use IO::File;
# spent 354µs making 1 call to Date::Manip::Recur::BEGIN@20 # spent 327µs making 1 call to Exporter::import
21343µs254µs
# spent 38µs (23+15) within Date::Manip::Recur::BEGIN@21 which was called: # once (23µs+15µs) by Date::Manip::Obj::new_recur at line 21
use feature 'switch';
# spent 38µs making 1 call to Date::Manip::Recur::BEGIN@21 # spent 15µs making 1 call to feature::import
22350µs224µs
# spent 20µs (16+4) within Date::Manip::Recur::BEGIN@22 which was called: # once (16µs+4µs) by Date::Manip::Obj::new_recur at line 22
use integer;
# spent 20µs making 1 call to Date::Manip::Recur::BEGIN@22 # spent 4µs making 1 call to integer::import
23#use re 'debug';
24
25315.8ms2118µs
# spent 68µs (18+50) within Date::Manip::Recur::BEGIN@25 which was called: # once (18µs+50µs) by Date::Manip::Obj::new_recur at line 25
use vars qw($VERSION);
# spent 68µs making 1 call to Date::Manip::Recur::BEGIN@25 # spent 50µs making 1 call to vars::import
261900ns$VERSION='6.11';
27
28########################################################################
29# BASE METHODS
30########################################################################
31
32sub is_recur {
33 return 1;
34}
35
36# Call this every time a new recur is put in to make sure everything is
37# correctly initialized.
38#
39
# spent 43µs (31+12) within Date::Manip::Recur::_init which was called: # once (31µs+12µs) by Date::Manip::Obj::new at line 152 of Date/Manip/Obj.pm
sub _init {
401025µs my($self) = @_;
41 my $dmb = $$self{'objs'}{'base'};
42
43 $$self{'err'} = '';
44 $$self{'data'}{'interval'} = []; # (Y, M, ...)
45 $$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
46 # [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
47 # ... )
48 $$self{'data'}{'base'} = undef;
49
50 # Get the default start/end dates
51
5213µs112µs given ($dmb->_config('recurrange')) {
# spent 12µs making 1 call to Date::Manip::Base::_config
53
5424µs when ('none') {
55 $$self{'data'}{'start'} = undef;
56 $$self{'data'}{'end'} = undef;
57 }
58
59 when ('year') {
60 my ($y) = $dmb->_now('y',1);
61 my $start = $self->new_date();
62 my $end = $self->new_date();
63 $start->set('date',[$y, 1, 1,00,00,00]);
64 $end->set ('date',[$y,12,31,23,59,59]);
65 }
66
67 when ('month') {
68 my ($y,$m) = $dmb->_now('now',1);
69 my $dim = $dmb->days_in_month($y,$m);
70 my $start = $self->new_date();
71 my $end = $self->new_date();
72 $start->set('date',[$y,$m, 1,00,00,00]);
73 $end->set ('date',[$y,$m,$dim,23,59,59]);
74 }
75
76 when ('week') {
77 my($y,$m,$d) = $dmb->_now('now',1);
78 my $w;
79 ($y,$w) = $dmb->week_of_year([$y,$m,$d]);
80 ($y,$m,$d) = @{ $dmb->week_of_year($y,$w) };
81 my($yy,$mm,$dd)
82 = @{ $dmb->_calc_date_ymwd([$y,$m,$d], [0,0,0,6], 0) };
83
84 my $start = $self->new_date();
85 my $end = $self->new_date();
86 $start->set('date',[$y, $m, $d, 00,00,00]);
87 $end->set ('date',[$yy,$mm,$dd,23,59,59]);
88 }
89
90 when ('day') {
91 my($y,$m,$d) = $dmb->_now('now',1);
92 my $start = $self->new_date();
93 my $end = $self->new_date();
94 $start->set('date',[$y,$m,$d,00,00,00]);
95 $end->set ('date',[$y,$m,$d,23,59,59]);
96 }
97
98 when ('all') {
99 my $start = $self->new_date();
100 my $end = $self->new_date();
101 $start->set('date',[0001,02,01,00,00,00]);
102 $end->set ('date',[9999,11,30,23,59,59]);
103 }
104 }
105
106 # Based on the modifiers, this is what we have to add to the
107 # start/end time in order to get a range which will produce
108 # modified dates guaranteed to fall within the start/end date
109 # range.
110 #
111 # The rtime values can automatically change things by up to one
112 # day.
113
114 $$self{'data'}{'flags'} = [];
115 $$self{'data'}{'startm'} = [0,0,0,-1,0,0,0];
116 $$self{'data'}{'endm'} = [0,0,0, 1,0,0,0];
117}
118
119sub _init_args {
120 my($self) = @_;
121
122 my @args = @{ $$self{'args'} };
123 if (@args) {
124 $self->parse(@args);
125 }
126}
127
128########################################################################
129# METHODS
130########################################################################
131
132sub parse {
133 my($self,$string,@args) = @_;
134
135 # Test if $string = FREQ
136
137 my $err = $self->frequency($string);
138 if (! $err) {
139 $string = '';
140 }
141
142 # Test if $string = "FREQ*..." and FREQ contains an '*'.
143
144 if ($err) {
145 $self->err(1);
146
147 $string =~ s/\s*\*\s*/\*/g;
148
149 if ($string =~ /^([^*]*\*[^*]*)\*/) {
150 my $freq = $1;
151 $err = $self->frequency($freq);
152 if (! $err) {
153 $string =~ s/^\Q$freq\E\*//;
154 }
155 } else {
156 $err = 1;
157 }
158 }
159
160 # Test if $string = "FREQ*..." and FREQ does NOT contains an '*'.
161
162 if ($err) {
163 $self->err(1);
164
165 if ($string =~ s/^([^*]*)\*//) {
166 my $freq = $1;
167 $err = $self->frequency($freq);
168 if (! $err) {
169 $string =~ s/^\Q$freq\E\*//;
170 }
171 } else {
172 $err = 1;
173 }
174 }
175
176 if ($err) {
177 $$self{'err'} = "[frequency] Invalid frequency string";
178 return 1;
179 }
180
181 # Handle MODIFIERS from string and arguments
182
183 my @tmp = split(/\*/,$string);
184
185 if (@tmp) {
186 my $tmp = shift(@tmp);
187 $err = $self->modifiers($tmp) if ($tmp);
188 return 1 if ($err);
189 }
190 if (@args) {
191 my $tmp = $args[0];
192 if ($tmp && ! ref($tmp)) {
193 $err = $self->modifiers($tmp);
194 if ($err) {
195 $self->err(1);
196 $err = 0;
197 } else {
198 shift(@args);
199 }
200 }
201 }
202
203 # Handle BASE
204
205 if (@tmp) {
206 my $tmp = shift(@tmp);
207 if (defined($tmp) && $tmp) {
208 my $base = $self->new_date();
209 $err = $base->parse($tmp);
210 return 1 if ($err);
211 $err = $self->base($tmp);
212 return 1 if ($err);
213 }
214 }
215 if (@args) {
216 my $tmp = shift(@args);
217 $err = $self->base($tmp) if (defined($tmp) && $tmp);
218 return 1 if ($err);
219 }
220
221 # Handle START
222
223 if (@tmp) {
224 my $tmp = shift(@tmp);
225 if (defined($tmp) && $tmp) {
226 my $start = $self->new_date();
227 $err = $start->parse($tmp);
228 return 1 if ($err);
229 $err = $self->start($tmp);
230 return 1 if ($err);
231 }
232 }
233 if (@args) {
234 my $tmp = shift(@args);
235 $err = $self->start($tmp) if (defined($tmp) && $tmp);
236 return 1 if ($err);
237 }
238
239 # END
240
241 if (@tmp) {
242 my $tmp = shift(@tmp);
243 if (defined($tmp) && $tmp) {
244 my $end = $self->new_date();
245 $err = $end->parse($tmp);
246 return 1 if ($err);
247 $err = $self->end($tmp);
248 return 1 if ($err);
249 }
250 }
251 if (@args) {
252 my $tmp = shift(@args);
253 $err = $self->end($tmp) if (defined($tmp) && $tmp);
254 return 1 if ($err);
255 }
256
257 if (@tmp) {
258 $$self{'err'} = "[frequency] String contains invalid elements";
259 return 1;
260 }
261 if (@args) {
262 $$self{'err'} = "[frequency] Unknown arguments";
263 return 1;
264 }
265
266 return 0;
267}
268
269sub frequency {
270 my($self,$string) = @_;
271 $self->_init();
272
273 my (@int,@rtime);
274
275 PARSE: {
276
277 # Standard frequency notation
278
279 my $stdrx = $self->_rx('std');
280 if ($string =~ $stdrx) {
281 my($l,$r) = @+{qw(l r)};
282
283 if (defined($l)) {
284 $l =~ s/^\s*:/0:/;
285 $l =~ s/:\s*$/:0/;
286 $l =~ s/::/:0:/g;
287
288 @int = split(/:/,$l);
289 }
290
291 if (defined($r)) {
292 $r =~ s/^\s*:/0:/;
293 $r =~ s/:\s*$/:0/;
294 $r =~ s/::/:0:/g;
295
296 @rtime = split(/:/,$r);
297 }
298
299 last PARSE;
300 }
301
302 # Other frequency strings
303
304 # Strip out some words to ignore
305
306 my $ignrx = $self->_rx('ignore');
307 $string =~ s/$ignrx/ /g;
308
309 my $eachrx = $self->_rx('each');
310 my $each = 0;
311 if ($string =~ s/$eachrx/ /g) {
312 $each = 1;
313 }
314
315 $string =~ s/\s*$//;
316
317 if (! $string) {
318 $$self{'err'} = "[frequency] Invalid frequency string";
319 return 1;
320 }
321
322 my($l,$r);
323 my $err = $self->_parse_lang($string);
324 if ($err) {
325 $$self{'err'} = "[frequency] Invalid frequency string";
326 return 1;
327 }
328 return 0;
329 }
330
331 # If the interval consists only of zeros, the last entry is changed
332 # to 1.
333
334 if (@int) {
335 TEST_INT: {
336 for my $i (@int) {
337 last TEST_INT if ($i);
338 }
339 $int[$#int] = 1;
340 }
341 }
342
343 # If @int contains 2 or 3 elements, move a trailing 0 to the start
344 # of @rtime.
345
346 while (@int &&
347 ($#int == 1 || $#int == 2) &&
348 ($int[$#int] == 0)) {
349 pop(@int);
350 unshift(@rtime,0);
351 }
352
353 # Test the format of @rtime.
354 #
355 # Turn it to:
356 # @rtime = ( NUM|RANGE, NUM|RANGE, ...)
357 # where
358 # NUM is an integer
359 # RANGE is [NUM1,NUM2]
360
361 my $rfieldrx = $self->_rx('rfield');
362 my $rrangerx = $self->_rx('rrange');
363 my @type = qw(y m w d h mn s);
364 while ($#type > $#rtime) {
365 shift(@type);
366 }
367
368 foreach my $rfield (@rtime) {
369 my $type = shift(@type);
370
371 if ($rfield !~ $rfieldrx) {
372 $$self{'err'} = "[parse] Invalid rtime string";
373 return 1;
374 }
375
376 my @rfield = split(/,/,$rfield);
377 my @val;
378
379 foreach my $vals (@rfield) {
380 if ($vals =~ $rrangerx) {
381 my ($num1,$num2) = ($1,$2);
382
383 if ( ($num1 < 0 || $num2 < 0) &&
384 ($type ne 'w' && $type ne 'd') ) {
385 $$self{'err'} = "[parse] Negative values allowed for day/week";
386 return 1;
387 }
388
389 if ( ($num1 > 0 && $num2 > 0) ||
390 ($num1 < 0 && $num2 < 0) ) {
391 if ($num1 > $num2) {
392 $$self{'err'} = "[parse] Invalid rtime range string";
393 return 1;
394 }
395 push(@val,$num1..$num2);
396 } else {
397 push(@val,[$num1,$num2]);
398 }
399
400 } else {
401 if ($vals < 0 &&
402 ($type ne 'w' && $type ne 'd') ) {
403 $$self{'err'} = "[parse] Negative values allowed for day/week";
404 return 1;
405 }
406 push(@val,$vals);
407 }
408 }
409
410 $rfield = [ @val ];
411 }
412
413 # Store it (also, get the default range modifiers).
414
415 $$self{'data'}{'interval'} = [ @int ];
416 $$self{'data'}{'rtime'} = [ @rtime ];
417 $self->modifiers();
418
419 return 0;
420}
421
422sub _parse_lang {
423 my($self,$string) = @_;
424 my $dmb = $$self{'objs'}{'base'};
425
426 # Test the regular expression
427
428 my $rx = $self->_rx('every');
429
430 return 1 if ($string !~ $rx);
431 my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) =
432 @+{qw(month week day last nth day_name day_abb mon_name mon_abb n y)};
433
434 # Convert wordlist values to calendar values
435
436 my $dow;
437 if (defined($day_name) || defined($day_abb)) {
438 if (defined($day_name)) {
439 $dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{lc($day_name)};
440 } else {
441 $dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{lc($day_abb)};
442 }
443 }
444
445 my $mmm;
446 if (defined($mon_name) || defined($mon_abb)) {
447 if (defined($mon_name)) {
448 $mmm = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($mon_name)};
449 } else {
450 $mmm = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mon_abb)};
451 }
452 }
453
454 if (defined($nth)) {
455 $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
456 }
457
458 # Get the frequencies
459
460 my($freq);
461 if (defined($dow)) {
462 if (defined($mmm)) {
463 if (defined($last)) {
464 # last DoW in MMM [YY]
465 $freq = "1*$mmm:-1:$dow:0:0:0";
466
467 } elsif (defined($nth)) {
468 # Nth DoW in MMM [YY]
469 $freq = "1*$mmm:$nth:$dow:0:0:0";
470
471 } else {
472 # every DoW in MMM [YY]
473 $freq = "1*$mmm:1-5:$dow:0:0:0";
474 }
475
476 } else {
477 if (defined($last)) {
478 # last DoW in every month [in YY]
479 $freq = "0:1*-1:$dow:0:0:0";
480
481 } elsif (defined($nth)) {
482 # Nth DoW in every month [in YY]
483 $freq = "0:1*$nth:$dow:0:0:0";
484
485 } else {
486 # every DoW in every month [in YY]
487 $freq = "0:1*1-5:$dow:0:0:0";
488 }
489 }
490
491 } elsif (defined($day)) {
492 if (defined($month)) {
493 if (defined($nth)) {
494 # Nth day of every month [YY]
495 $freq = "0:1*0:$nth:0:0:0";
496
497 } elsif (defined($last)) {
498 # last day of every month [YY]
499 $freq = "0:1*0:-1:0:0:0";
500
501 } else {
502 # every day of every month [YY]
503 $freq = "0:0:0:1*0:0:0";
504 }
505
506 } else {
507 if (defined($nth)) {
508 # every Nth day [YY]
509 $freq = "0:0:0:$nth*0:0:0";
510
511 } elsif (defined($n)) {
512 # every N days [YY]
513 $freq = "0:0:0:$n*0:0:0";
514
515 } else {
516 # every day [YY]
517 $freq = "0:0:0:1*0:0:0";
518 }
519 }
520 }
521
522 # Get the range (if YY is included)
523
524 if (defined($y)) {
525 $y = $dmb->_fix_year($y);
526 my $start = "${y}010100:00:00";
527 my $end = "${y}123123:59:59";
528
529 return $self->parse($freq,undef,$start,$end);
530 }
531
532 return $self->frequency($freq)
533}
534
535sub _date {
536 my($self,$op,$date_or_string) = @_;
537
538 # Make sure the argument is a date
539
540 if (ref($date_or_string) eq 'Date::Manip::Date') {
541 $$self{'data'}{$op} = $date_or_string;
542
543 } elsif (ref($date_or_string)) {
544 $$self{'err'} = "Invalid $op date object";
545 return 1;
546
547 } else {
548 my $date = $self->new_date();
549 my $err = $date->parse($date_or_string);
550 if ($err) {
551 $$self{'err'} = "Invalid $op date string";
552 return 1;
553 }
554 $$self{'data'}{$op} = $date;
555 }
556
557 return 0;
558}
559
560sub start {
561 my($self,$start) = @_;
562 $self->_date('start',$start);
563}
564
565sub end {
566 my($self,$end) = @_;
567 $self->_date('end',$end);
568}
569
570sub base {
571 my($self,$base) = @_;
572 $self->_date('base',$base);
573}
574
575sub modifiers {
576 my($self,@flags) = @_;
577 my $dmb = $$self{'objs'}{'base'};
578 if ($#flags == 0) {
579 @flags = split(/,/,lc($flags[0]));
580 }
581
582 # Add these flags to the list
583
584 if (@flags && $flags[0] eq "+") {
585 shift(@flags);
586 my @tmp = @{ $$self{'data'}{'flags'} };
587 @flags = (@tmp,@flags) if (@tmp);
588 }
589
590 # Set up a base modifier:
591 # @int = () : +/- 1 year
592 # @int = (y) : +/- 1 year
593 # @int = (y,m) : +/- 1 month
594 # @int = (y,m,w) : +/- 1 month
595 # @int = (y,m,w,d) : +/- 1 week
596 # @int = (y...h) : +/- 1 day
597 # @int = (y...mn) : +/- 1 hour
598 # @int = (y...s) : +/- 1 minute
599
600 my @int = @{ $$self{'data'}{'interval'} };
601 my(@startm,@endm);
602 my $n = $#int + 1;
603
604 given($n) {
605
606 when ([0,1]) {
607 @endm = (1,0,0,0,0,0,0);
608 }
609
610 when ([2,3]) {
611 @endm = (0,1,0,0,0,0,0);
612 }
613
614 when (4) {
615 @endm = (0,0,0,7,0,0,0);
616 }
617
618 when (5) {
619 @endm = (0,0,0,1,0,0,0);
620 }
621
622 when (6) {
623 @endm = (0,0,0,0,1,0,0);
624 }
625
626 when (7) {
627 @endm = (0,0,0,0,0,1,0);
628 }
629 }
630 @startm = map { -1*$_ } @endm;
631
632 # Examine each modifier to see how it impacts the range
633
634 foreach my $flag (@flags) {
635
636 given($flag) {
637
638 when (/^pd([1-7])$/) {
639 $startm[3] -= 7;
640 $endm[3] -= 1;
641 }
642
643 when (/^pt([1-7])$/) {
644 $startm[3] -= 6;
645 $endm[3] -= 0;
646 }
647
648 when (/^nd([1-7])$/) {
649 $startm[3] += 1;
650 $endm[3] += 7;
651 }
652
653 when (/^nt([1-7])$/) {
654 $startm[3] += 0;
655 $endm[3] += 6;
656 }
657
658 when (/^fd(\d+)$/) {
659 my $n = $1;
660 $startm[3] += $n;
661 $endm[3] += $n;
662 }
663
664 when (/^bd(\d+)$/) {
665 my $n = $1;
666 $startm[3] -= $n;
667 $endm[3] -= $n;
668 }
669
670 #
671 # The business day flags are imperfectly handled... it's quite possible to
672 # make so many holidays that moving forward 1 working day could correspond
673 # to moving forward many days.
674 #
675
676 when (/^(fw|bw)(\d+)$/) {
677 my ($t,$n) = ($1,$2);
678
679 my $wwbeg = $dmb->_config('workweekbeg');
680 my $wwend = $dmb->_config('workweekend');
681 my $wwlen = $wwend - $wwbeg + 1;
682 my $wkend = 7 - $wwlen;
683 my $fudge = $dmb->_config('recurnumfudgedays');
684 # How many weekends likely in the interval? Take best guess for maximum
685 # number of weeks and add 1 for a fudge factor.
686 my $num = int($n/$wwlen) + 2;
687
688 if ($t eq 'fw') {
689 $startm[3] += $n;
690 $endm[3] += $n + $num*$wkend + $fudge;
691 } else {
692 $startm[3] -= $n + $num*$wkend + $fudge;
693 $endm[3] -= $n;
694 }
695 }
696
697 when ([qw( cwd cwn cwp nwd pwd dwd )]) {
698 # For closest work day, we'll move backwards/forwards 1
699 # weekend (+ 1 day) plus the fudge factor.
700 my $wwbeg = $dmb->_config('workweekbeg');
701 my $wwend = $dmb->_config('workweekend');
702 my $wwlen = $wwend - $wwbeg + 1;
703 my $wkend = 7 - $wwlen;
704 my $fudge = $dmb->_config('recurnumfudgedays');
705
706 if ($flag eq 'pwd') {
707 $startm[3] -= $wkend+1 + $fudge;
708 $endm[3] -= 1;
709
710 } elsif ($flag eq 'nwd') {
711 $startm[3] += 1;
712 $endm[3] += $wkend+1 + $fudge;
713
714 } else {
715 $startm[3] -= $wkend+1 + $fudge;
716 $endm[3] += $wkend+1 + $fudge;
717 }
718 }
719
720 when ('easter') {
721 $startm[0]--;
722 $endm[0]++;
723 }
724
725 default {
726 $$self{'err'} = "[modifiers]: invalid modifier: $flag";
727 return 1;
728 }
729 }
730 }
731
732 $$self{'data'}{'startm'} = [ @startm ];
733 $$self{'data'}{'endm'} = [ @endm ];
734 $$self{'data'}{'flags'} = [ @flags ];
735 return 0;
736}
737
738sub dates {
739 my($self,$start2,$end2) = @_;
740 $self->err(1);
741
742 my $dmb = $$self{'objs'}{'base'};
743 $dmb->_update_now(); # Update NOW
744 my @int = @{ $$self{'data'}{'interval'} };
745 my @rtime = @{ $$self{'data'}{'rtime'} };
746 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
747
748 #
749 # Get the start and end dates based on the dates store in the
750 # recurrence and the dates passed in as arguments.
751 #
752
753 if (defined($start2) &&
754 (! ref($start2) || ref($start2) ne 'Date::Manip::Date' ||
755 $start2->err())) {
756 $$self{'err'} = 'Start argument must be a date object.';
757 return ();
758 }
759 if (defined($end2) &&
760 (! ref($end2) || ref($end2) ne 'Date::Manip::Date' ||
761 $end2->err())) {
762 $$self{'err'} = 'End argument must be a date object.';
763 return ();
764 }
765
766 my $start = $$self{'data'}{'start'};
767 my $end = $$self{'data'}{'end'};
768
769 if (defined($start) && defined($start2)) {
770 # Choose the later of the two
771 if ($start->cmp($start2) == -1) {
772 $start = $start2;
773 }
774 } elsif (defined($start2)) {
775 $start = $start2;
776 }
777
778 if (defined($end) && defined($end2)) {
779 # Choose the earlier of the two
780 if ($end->cmp($end2) == 1) {
781 $end = $end2;
782 }
783 } elsif (defined($end2)) {
784 $end = $end2;
785 }
786
787 #
788 # Make sure that basedate, start, and end are set as needed
789 #
790 # Start/end are required unless *Y:M:W:D:H:MN:S
791 # Basedate required unless *Y:M:W:D:H:MN:S or @int = (0*,1)
792 #
793
794
795 if ($#int != -1) {
796 if (! defined $start) {
797 $$self{'err'} = 'Start date required';
798 return ();
799 }
800 if ($$start{'err'}) {
801 $$self{'err'} = 'Start date invalid';
802 return ();
803 }
804
805 if (! defined $end) {
806 $$self{'err'} = 'End date required';
807 return ();
808 }
809 if ($$end{'err'}) {
810 $$self{'err'} = 'End date invalid';
811 return ();
812 }
813
814 if ($start->cmp($end) == 1) {
815 return ();
816 }
817 }
818
819 my $every = 0;
820 my $tmp = join('',@int);
821
822 if ($tmp eq '' || $tmp =~ /^0*1$/) {
823 $$self{'data'}{'base'} = $start;
824 $every = 1 if ($tmp ne '');
825
826 } else {
827 if (! defined $$self{'data'}{'base'}) {
828 $$self{'err'} = 'Base date required';
829 return ();
830 }
831 my $date = $$self{'data'}{'base'};
832 if ($$date{'err'}) {
833 $$self{'err'} = 'Base date invalid';
834 return ();
835 }
836 }
837
838 #
839 # Handle the Y/M/W/D portion.
840 #
841
842 my (@date,@tmp);
843 my ($err,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n);
844 my $n = $#int + 1;
845
846 my $m_empty = $self->_field_empty($mf);
847 my $w_empty = $self->_field_empty($wf);
848 my $d_empty = $self->_field_empty($df);
849
850 given($n) {
851
852 when ([0,1]) {
853 #
854 # *Y:M:W:D:H:MN:S
855 # Y*M:W:D:H:MN:S
856 #
857
858 if ($#int == -1) {
859 ($err,@y) = $self->_rtime_values('y',$yf);
860 return () if ($err);
861 } else {
862 my @tmp = $self->_int_values($every,$yf,$start,$end);
863 @y = map { $$_[0] } @tmp;
864 }
865
866 if ( ($m_empty && $w_empty && $d_empty) ||
867 (! $m_empty && $w_empty) ) {
868
869 # *0:0:0:0 Jan 1 of the current year
870 # *1:0:0:0 Jan 1, 0001
871 # *0:2:0:0 Feb 1 of the current year
872 # *1:2:0:0 Feb 1, 0001
873 # *0:2:0:4 Feb 4th of the current year
874 # *1:2:0:4 Feb 4th, 0001
875 # 1*0:0:0 every year on Jan 1
876 # 1*2:0:0 every year on Feb 1
877 # 1*2:0:4 every year on Feb 4th
878
879 $mf = [1] if ($m_empty);
880 $df = [1] if ($d_empty);
881
882 ($err,@m) = $self->_rtime_values('m',$mf);
883 return () if ($err);
884
885 foreach my $y (@y) {
886 foreach my $m (@m) {
887 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
888 return () if ($err);
889 foreach my $d (@d) {
890 push(@date,[$y,$m,$d,0,0,0]);
891 }
892 }
893 }
894
895 } elsif ($m_empty) {
896
897 if ($w_empty) {
898
899 # *0:0:0:4 the 4th day of the current year
900 # *1:0:0:4 the 4th day of 0001
901 # 1*0:0:4 every year on the 4th day of the year
902
903 foreach my $y (@y) {
904 ($err,@doy) = $self->_rtime_values('day_of_year',$df,$y);
905 return () if ($err);
906 foreach my $doy (@doy) {
907 my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) };
908 push(@date,[$yy,$mm,$dd,0,0,0]);
909 }
910 }
911
912 } elsif ($d_empty) {
913
914 # *0:0:3:0 the first day of the 3rd week of the curr year
915 # *1:0:3:0 the first day of the 3rd week of 0001
916 # 1*0:3:0 every year on the first day of 3rd week of year
917
918 foreach my $y (@y) {
919 ($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y);
920 return () if ($err);
921 foreach my $woy (@woy) {
922 my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) };
923 push(@date,[$yy,$mm,$dd,0,0,0]);
924 }
925 }
926
927 } else {
928
929 # *1:0:3:4 in 0001 on the 3rd Thur of the year
930 # *0:0:3:4 on the 3rd Thur of the current year
931 # 1*0:3:4 every year on the 3rd Thur of the year
932
933 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
934 return () if ($err);
935 foreach my $y (@y) {
936 foreach my $dow (@dow) {
937 ($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow);
938 return () if ($err);
939 foreach my $n (@n) {
940 my $ymd = $dmb->nth_day_of_week($y,$n,$dow);
941 my($yy,$mm,$dd) = @$ymd;
942 push(@date,[$yy,$mm,$dd,0,0,0]);
943 }
944 }
945 }
946 }
947
948 } else {
949
950 # *1:2:3:4 in Feb 0001 on the 3rd Thur of the month
951 # *0:2:3:4 on the 3rd Thur of Feb in the curr year
952 # *1:2:3:0 the 3rd occurence of FirstDay in Feb 0001
953 # *0:2:3:0 the 3rd occurence of FirstDay in Feb of curr year
954 # 1*2:3:4 every year in Feb on the 3rd Thur
955 # 1*2:3:0 every year on the 3rd occurence of FirstDay in Feb
956
957 ($err,@m) = $self->_rtime_values('m',$mf);
958 return () if ($err);
959 if ($d_empty) {
960 @dow = ($dmb->_config('firstday'));
961 } else {
962 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
963 return () if ($err);
964 }
965
966 foreach my $y (@y) {
967 foreach my $m (@m) {
968 foreach my $dow (@dow) {
969 ($err,@n) = $self->_rtime_values('dow_of_month',
970 $wf,$y,$m,$dow);
971 return () if ($err);
972 foreach my $n (@n) {
973 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
974 my($yy,$mm,$dd) = @$ymd;
975 push(@date,[$yy,$mm,$dd,0,0,0]);
976 }
977 }
978 }
979 }
980 }
981 }
982
983 when (2) {
984 #
985 # Y:M*W:D:H:MN:S
986 #
987
988 my @tmp = $self->_int_values($every,$yf,$mf,$start,$end);
989
990 if ($w_empty) {
991
992 # 0:2*0:0 every 2 months on the first day of the month
993 # 0:2*0:4 every 2 months on the 4th day of the month
994 # 1:2*0:0 every 1 year, 2 months on the first day of the month
995 # 1:2*0:4 every 1 year, 2 months on the 4th day of the month
996
997 $df = [1] if ($d_empty);
998
999 foreach my $date (@tmp) {
1000 my($y,$m) = @$date;
1001 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1002 return () if ($err);
1003 foreach my $d (@d) {
1004 push(@date,[$y,$m,$d,0,0,0]);
1005 }
1006 }
1007
1008 } else {
1009
1010 # 0:2*3:0 every 2 months on the 3rd occurence of FirstDay
1011 # 0:2*3:4 every 2 months on the 3rd Thur of the month
1012 # 1:2*3:0 every 1 year, 2 months on 3rd occurence of FirstDay
1013 # 1:2*3:4 every 1 year, 2 months on the 3rd Thur of the month
1014
1015 if ($d_empty) {
1016 @dow = ($dmb->_config('firstday'));
1017 } else {
1018 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1019 return () if ($err);
1020 }
1021
1022 foreach my $date (@tmp) {
1023 my($y,$m) = @$date;
1024 foreach my $dow (@dow) {
1025 ($err,@n) = $self->_rtime_values('dow_of_month',
1026 $wf,$y,$m,$dow);
1027 return () if ($err);
1028 foreach my $n (@n) {
1029 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1030 my($yy,$mm,$dd) = @$ymd;
1031 push(@date,[$yy,$mm,$dd,0,0,0]);
1032 }
1033 }
1034 }
1035 }
1036 }
1037
1038 when (3) {
1039 #
1040 # Y:M:W*D:H:MN:S
1041 #
1042
1043 # 0:0:3*0 every 3 weeks on FirstDay
1044 # 0:0:3*4 every 3 weeks on Thur
1045 # 0:2:3*0 every 2 months, 3 weeks on FirstDay
1046 # 0:2:3*4 every 2 months, 3 weeks on Thur
1047 # 1:0:3*0 every 1 year, 3 weeks on FirstDay
1048 # 1:0:3*4 every 1 year, 3 weeks on Thur
1049 # 1:2:3*0 every 1 year, 2 months, 3 weeks on FirstDay
1050 # 1:2:3*4 every 1 year, 2 months, 3 weeks on Thur
1051
1052 my @tmp = $self->_int_values($every,$yf,$mf,$wf,$start,$end);
1053
1054 my $fdow = $dmb->_config('firstday');
1055 if ($d_empty) {
1056 @dow = ($fdow);
1057 } else {
1058 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1059 return () if ($err);
1060 }
1061
1062 foreach my $date (@tmp) {
1063 my($y,$m,$d) = @$date;
1064 my ($mm,$dd);
1065 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]);
1066 ($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) };
1067
1068 foreach my $dow (@dow) {
1069 $dow += 7 if ($dow < $fdow);
1070 my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) };
1071 push(@date,[$yyy,$mmm,$ddd]);
1072 }
1073 }
1074 }
1075
1076 when (4) {
1077 #
1078 # Y:M:W:D*H:MN:S
1079 #
1080
1081 @date = $self->_int_values($every,$yf,$mf,$wf,$df,$start,$end);
1082 }
1083
1084 when (5) {
1085 #
1086 # Y:M:W:D:H*MN:S
1087 #
1088
1089 @date = $self->_int_values($every,$yf,$mf,$wf,$df,$hf,$start,$end);
1090 }
1091
1092 when (6) {
1093 #
1094 # Y:M:W:D:H:MN*S
1095 #
1096
1097 @date = $self->_int_values($every,$yf,$mf,$wf,$df,$hf,$mnf,$start,$end);
1098 }
1099
1100 when (7) {
1101 #
1102 # Y:M:W:D:H:MN:S
1103 #
1104
1105 @date = $self->_int_values($every,$yf,$mf,$wf,$df,$hf,$mnf,$sf,$start,$end);
1106 }
1107 }
1108
1109 #
1110 # Handle the H/MN/S portion.
1111 #
1112
1113 # Do seconds
1114 if (@rtime) {
1115 pop(@rtime);
1116
1117 ($err,@s) = $self->_rtime_values('s',$sf);
1118 return () if ($err);
1119 $self->_field_add_values(\@date,5,@s);
1120 }
1121
1122 # Do minutes
1123 if (@rtime) {
1124 pop(@rtime);
1125
1126 ($err,@mn) = $self->_rtime_values('mn',$mnf);
1127 return () if ($err);
1128 $self->_field_add_values(\@date,4,@mn);
1129 }
1130
1131 # Do hours
1132 if (@rtime) {
1133 pop(@rtime);
1134
1135 ($err,@h) = $self->_rtime_values('h',$hf);
1136 return () if ($err);
1137 $self->_field_add_values(\@date,3,@h);
1138 }
1139
1140 #
1141 # Apply modifiers
1142 #
1143
1144 my @flags = @{ $$self{'data'}{'flags'} };
1145 if (@flags) {
1146 my $obj = $self->new_date();
1147
1148 foreach my $date (@date) {
1149 my ($y,$m,$d,$h,$mn,$s) = @$date;
1150
1151 foreach my $flag (@flags) {
1152
1153 my(@wd,$today);
1154 given($flag) {
1155
1156 when ('easter') {
1157 ($m,$d) = $self->_easter($y);
1158 }
1159
1160 when (/^([pn])([dt])([1-7])$/) {
1161 my($forw,$today,$dow) = ($1,$2,$3);
1162 $forw = ($forw eq 'p' ? 0 : 1);
1163 $today = ($today eq 'd' ? 0 : 1);
1164 ($y,$m,$d,$h,$mn,$s) =
1165 @{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) };
1166 }
1167
1168 when (/^([fb])([dw])(\d+)$/) {
1169 my($prev,$business,$n) = ($1,$2,$3);
1170 $prev = ($prev eq 'b' ? 1 : 0);
1171 $business = ($business eq 'w' ? 1 : 0);
1172
1173 if ($business) {
1174 ($y,$m,$d,$h,$mn,$s) =
1175 @{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) };
1176 } else {
1177 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) };
1178 }
1179 }
1180
1181 when ('nwd') {
1182 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1183 ($y,$m,$d,$h,$mn,$s) =
1184 @{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) };
1185 }
1186 }
1187
1188 when ('pwd') {
1189 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1190 ($y,$m,$d,$h,$mn,$s) =
1191 @{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) };
1192 }
1193 }
1194
1195 when ('dwd') {
1196 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1197 continue;
1198 }
1199 }
1200
1201 when (['cwd','dwd']) {
1202 if ($dmb->_config('tomorrowfirst')) {
1203 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1204 } else {
1205 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1206 }
1207 continue;
1208 }
1209
1210 when ('cwn') {
1211 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1212 $today = 0;
1213 continue;
1214 }
1215
1216 when ('cwp') {
1217 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1218 $today = 0;
1219 continue;
1220 }
1221
1222 default {
1223 while (1) {
1224 my(@d,$off);
1225
1226 # Test in the first direction
1227
1228 @d = @{ $wd[0] };
1229 $off = $wd[1];
1230 @d = @{ $dmb->calc_date_days(\@d,$off) };
1231
1232 if ($obj->__is_business_day(\@d,0)) {
1233 ($y,$m,$d,$h,$mn,$s) = @d;
1234 last;
1235 }
1236
1237 $wd[0] = [@d];
1238
1239 # Test in the other direction
1240
1241 @d = @{ $wd[2] };
1242 $off = $wd[3];
1243 @d = @{ $dmb->calc_date_days(\@d,$off) };
1244
1245 if ($obj->__is_business_day(\@d,0)) {
1246 ($y,$m,$d,$h,$mn,$s) = @d;
1247 last;
1248 }
1249
1250 $wd[2] = [@d];
1251 }
1252 }
1253
1254 }
1255 }
1256
1257 @$date = ($y,$m,$d,$h,$mn,$s);
1258 }
1259 }
1260
1261 #
1262 # Convert the dates (which fall into the valid range) to objects.
1263 #
1264
1265 my(@ret,@start,@end);
1266 if (defined $start) {
1267 @start = @{ $$start{'data'}{'date'} };
1268 }
1269 if (defined $end) {
1270 @end = @{ $$end{'data'}{'date'} };
1271 }
1272
1273 foreach my $date (@date) {
1274 my @d = @$date;
1275 if (@start) {
1276 next if ($dmb->cmp(\@start,\@d) > 0);
1277 }
1278 if (@end) {
1279 next if ($dmb->cmp(\@d,\@end) > 0);
1280 }
1281
1282 my $obj = $self->new_date();
1283 $obj->set('date',\@d);
1284 push(@ret,$obj);
1285 }
1286
1287 #
1288 # Sort the dates
1289 #
1290
1291 @ret = sort { $a->cmp($b) } @ret;
1292 return @ret;
1293}
1294
1295########################################################################
1296# MISC
1297########################################################################
1298
1299sub _rx {
1300 my($self,$rx) = @_;
1301 my $dmb = $$self{'objs'}{'base'};
1302
1303 return $$dmb{'data'}{'rx'}{'recur'}{$rx}
1304 if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx});
1305
1306 if ($rx eq 'std') {
1307
1308 my $l = '[0-9]*';
1309 my $r = '[-,0-9]*';
1310 my $stdrx = "(?<l>$l:$l:$l:$l:$l:$l:$l)(?<r>)|" .
1311 "(?<l>$l:$l:$l:$l:$l:$l)\\*(?<r>$r)|" .
1312 "(?<l>$l:$l:$l:$l:$l)\\*(?<r>$r:$r)|" .
1313 "(?<l>$l:$l:$l:$l)\\*(?<r>$r:$r:$r)|" .
1314 "(?<l>$l:$l:$l)\\*(?<r>$r:$r:$r:$r)|" .
1315 "(?<l>$l:$l)\\*(?<r>$r:$r:$r:$r:$r)|" .
1316 "(?<l>$l)\\*(?<r>$r:$r:$r:$r:$r:$r)|" .
1317 "(?<l>)\\*(?<r>$r:$r:$r:$r:$r:$r:$r)";
1318 $$dmb{'data'}{'rx'}{'recur'}{$rx} = qr/^\s*(?:$stdrx)\s*$/;
1319
1320 } elsif ($rx eq 'rfield' ||
1321 $rx eq 'rnum' ||
1322 $rx eq 'rrange') {
1323
1324 my $num = '\-?\d+';
1325 my $range = "$num\-$num";
1326 my $val = "(?:$range|$num)";
1327 my $vals = "$val(?:,$val)*";
1328
1329 $$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/;
1330 $$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/;
1331 $$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/;
1332
1333 } elsif ($rx eq 'each') {
1334
1335 my $each = $$dmb{'data'}{'rx'}{'each'};
1336
1337 my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i;
1338 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx;
1339
1340 } elsif ($rx eq 'ignore') {
1341
1342 my $of = $$dmb{'data'}{'rx'}{'of'};
1343 my $on = $$dmb{'data'}{'rx'}{'on'};
1344
1345 my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i;
1346 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx;
1347
1348 } elsif ($rx eq 'every') {
1349
1350 my $month = $$dmb{'data'}{'rx'}{'fields'}[2];
1351 my $week = $$dmb{'data'}{'rx'}{'fields'}[3];
1352 my $day = $$dmb{'data'}{'rx'}{'fields'}[4];
1353
1354 my $last = $$dmb{'data'}{'rx'}{'last'};
1355 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
1356 my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
1357 my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0];
1358
1359 my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
1360 my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
1361 my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1362 my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0];
1363
1364 my $beg = '(?:^|\s+)';
1365 my $end = '(?:\s*$)';
1366
1367 $month = "$beg(?<month>$month)"; # months
1368 $week = "$beg(?<week>$week)"; # weeks
1369 $day = "$beg(?<day>$day)"; # days
1370
1371 $last = "$beg(?<last>$last)"; # last
1372 $nth = "$beg(?<nth>$nth)"; # 1st,2nd,...
1373 $nth_wom = "$beg(?<nth>$nth_wom)"; # 1st - 5th
1374 $nth_dom = "$beg(?<nth>$nth_dom)"; # 1st - 31st
1375 my $n = "$beg(?<n>\\d+)"; # 1,2,...
1376
1377 my $dow = "$beg(?:(?<day_name>$day_name)|(?<day_abb>$day_abb))"; # Sun|Sunday
1378 my $mmm = "$beg(?:(?<mon_name>$mon_name)|(?<mon_abb>$mon_abb))"; # Jan|January
1379
1380 my $y = "(?:$beg(?:(?<y>\\d\\d\\d\\d)|(?<y>\\d\\d)))?";
1381
1382 my $freqrx =
1383 "$nth_wom?$dow$mmm$y|" . # every DoW in MMM [YY]
1384 "$last$dow$mmm$y|" . # Nth DoW in MMM [YY]
1385 # last DoW in MMM [YY]
1386 # day_name|day_abb
1387 # mon_name|mon_abb
1388 # last*|nth*
1389 # y*
1390 "$nth_wom?$dow$month$y|" . # every DoW of every month [YY]
1391 "$last$dow$month$y|" . # Nth DoW of every month [YY]
1392 # last DoW of every month [YY]
1393 # day_name|day_abb
1394 # last*|nth*
1395 # y*
1396 "$nth_dom?$day$month$y|" . # every day of every month [YY]
1397 "$last$day$month$y|" . # Nth day of every month [YY]
1398 # last day of every month [YY]
1399 # day
1400 # month
1401 # nth*|last*
1402 # y*
1403 "$nth*$day$y|" . # every day [YY]
1404 "$n$day$y"; # every Nth day [YY]
1405 # every N days [YY]
1406 # day
1407 # nth*|n*
1408 # y*
1409
1410 $freqrx = qr/^(?:$freqrx)\s*$/i;
1411 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx;
1412 }
1413
1414 return $$dmb{'data'}{'rx'}{'recur'}{$rx};
1415}
1416
1417########################################################################
1418# MISC
1419########################################################################
1420
1421# This returns the date easter occurs on for a given year as ($month,$day).
1422# This is from the Calendar FAQ.
1423#
1424sub _easter {
1425 my($self,$y) = @_;
1426
1427 my($c) = $y/100;
1428 my($g) = $y % 19;
1429 my($k) = ($c-17)/25;
1430 my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30;
1431 $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11));
1432 my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
1433 my($l) = $i-$j;
1434 my($m) = 3 + ($l+40)/44;
1435 my($d) = $l + 28 - 31*($m/4);
1436 return ($m,$d);
1437}
1438
1439# This returns 1 if a field is empty.
1440#
1441sub _field_empty {
1442 my($self,$val) = @_;
1443
1444 if (ref($val)) {
1445 my @tmp = @$val;
1446 return 1 if ($#tmp == -1 ||
1447 ($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0]));
1448 return 0;
1449
1450 } else {
1451 return $val;
1452 }
1453}
1454
1455# This returns a list of values as determined by the interval value,
1456# the base date, and the range.
1457#
1458# Usage:
1459# _int_values($every,$y,$m,$w,$d,$h,$mn,$s,$start,$end);
1460#
1461# Every argument is optional (except $every and $y), so the following
1462# are valid:
1463# _int_values($every,$y,$m,$start,$end);
1464# _int_values($every,$y,$m,$w,$d,$start,$end);
1465#
1466sub _int_values {
1467 my($self,$every,@args) = @_;
1468 my $end = pop(@args);
1469 my $start = pop(@args);
1470 my $dmb = $$self{'objs'}{'base'};
1471 my @vals;
1472
1473 # Get the start, end, and base dates.
1474 #
1475 # Also, get the range of dates to search (which is the start and end
1476 # dates adjusted due to various modifiers.
1477
1478 my $base = $$self{'data'}{'base'};
1479 my @base = @{ $$base{'data'}{'date'} };
1480
1481 my @start = @{ $$start{'data'}{'date'} };
1482 my @startm = @{ $$self{'data'}{'startm'} };
1483
1484 my @end = @{ $$end{'data'}{'date'} };
1485 my @endm = @{ $$self{'data'}{'endm'} };
1486
1487 my @date0 = @{ $dmb->calc_date_delta(\@start,\@startm) };
1488 my @date1 = @{ $dmb->calc_date_delta(\@end,\@endm) };
1489
1490 # Get the delta which will be used to adjust the base date
1491 # from one recurrence to the next.
1492
1493 my @delta = @args;
1494 while ($#delta < 6) {
1495 push(@delta,0);
1496 }
1497
1498 # The base date will be used as the date for one recurrence.
1499 #
1500 # To begin with, move it so that it is before date0 (we have to
1501 # use the $subtract=2 form so we make sure that each step backward
1502 # results in a date which can step forward to the base date.
1503
1504 while ($dmb->cmp(\@base,\@date0) > -1) {
1505 @base = @{ $start->__calc_date_delta_inverse([@base],[@delta]) };
1506 }
1507
1508 # Now, move the base date to be on or after date0
1509
1510 while ($dmb->cmp(\@base,\@date0) == -1) {
1511 @base = @{ $dmb->calc_date_delta(\@base,\@delta) };
1512 }
1513
1514 # While the base date is on or before date1, add it to the
1515 # list and move forward.
1516
1517 while ($dmb->cmp(\@base,\@date1) < 1) {
1518 push(@vals,[@base]);
1519 @base = @{ $dmb->calc_date_delta(\@base,\@delta) };
1520 }
1521
1522 return @vals;
1523}
1524
1525# This returns a list of values that appear in a field in the rtime.
1526#
1527# $val is a listref, with each element being a value or a range.
1528#
1529# Usage:
1530# _rtime_values('y' ,$y);
1531# _rtime_values('m' ,$m);
1532# _rtime_values('week_of_year' ,$w ,$y);
1533# _rtime_values('dow_of_year' ,$w ,$y,$dow);
1534# _rtime_values('dow_of_month' ,$w ,$y,$m,$dow);
1535# _rtime_values('day_of_year' ,$d ,$y);
1536# _rtime_values('day_of_month' ,$d ,$y,$m);
1537# _rtime_values('day_of_week' ,$d);
1538# _rtime_values('h' ,$h);
1539# _rtime_values('mn' ,$mn);
1540# _rtime_values('s' ,$s);
1541#
1542# Returns ($err,@vals)
1543#
1544sub _rtime_values {
1545 my($self,$type,$val,@args) = @_;
1546 my $dmb = $$self{'objs'}{'base'};
1547
1548 given($type) {
1549
1550 when ('h') {
1551 @args = (0,0,23,23);
1552 }
1553
1554 when ('mn') {
1555 @args = (0,0,59,59);
1556 }
1557
1558 when ('s') {
1559 @args = (0,0,59,59);
1560 }
1561
1562 when ('y') {
1563 my ($curry) = $dmb->_now('y',1);
1564 foreach my $y (@$val) {
1565 $y = $curry if (! ref($y) && $y==0);
1566 }
1567
1568 @args = (0,1,9999,9999);
1569 }
1570
1571 when ('m') {
1572 @args = (0,1,12,12);
1573 }
1574
1575 when ('week_of_year') {
1576 my($y) = @args;
1577 my $wiy = $dmb->weeks_in_year($y);
1578 @args = (1,1,$wiy,53);
1579 }
1580
1581 when ('dow_of_year') {
1582 my($y,$dow) = @args;
1583
1584 # Get the 1st occurence of $dow
1585 my $d0 = 1;
1586 my $dow0 = $dmb->day_of_week([$y,1,$d0]);
1587 if ($dow > $dow0) {
1588 $d0 += ($dow-$dow0);
1589 } elsif ($dow < $dow0) {
1590 $d0 += 7-($dow0-$dow);
1591 }
1592
1593 # Get the last occurrence of $dow
1594 my $d1 = 31;
1595 my $dow1 = $dmb->day_of_week([$y,12,$d1]);
1596 if ($dow1 > $dow) {
1597 $d1 -= ($dow1-$dow);
1598 } elsif ($dow1 < $dow) {
1599 $d1 -= 7-($dow-$dow1);
1600 }
1601
1602 # Find out the number of occurrenced of $dow
1603 my $doy1 = $dmb->day_of_year([$y,12,$d1]);
1604 my $n = ($doy1 - $d0)/7 + 1;
1605
1606 # Get the list of @w
1607 @args = (1,1,$n,53);
1608 }
1609
1610 when ('dow_of_month') {
1611 my($y,$m,$dow) = @args;
1612
1613 # Get the 1st occurence of $dow in the month
1614 my $d0 = 1;
1615 my $dow0 = $dmb->day_of_week([$y,$m,$d0]);
1616 if ($dow > $dow0) {
1617 $d0 += ($dow-$dow0);
1618 } elsif ($dow < $dow0) {
1619 $d0 += 7-($dow0-$dow);
1620 }
1621
1622 # Get the last occurrence of $dow
1623 my $d1 = $dmb->days_in_month($y,$m);
1624 my $dow1 = $dmb->day_of_week([$y,$m,$d1]);
1625 if ($dow1 > $dow) {
1626 $d1 -= ($dow1-$dow);
1627 } elsif ($dow1 < $dow) {
1628 $d1 -= 7-($dow-$dow1);
1629 }
1630
1631 # Find out the number of occurrenced of $dow
1632 my $n = ($d1 - $d0)/7 + 1;
1633
1634 # Get the list of @w
1635 @args = (1,1,$n,5);
1636 }
1637
1638 when ('day_of_year') {
1639 my($y) = @args;
1640 my $diy = $dmb->days_in_year($y);
1641 @args = (1,1,$diy,366);
1642 }
1643
1644 when ('day_of_month') {
1645 my($y,$m) = @args;
1646 my $dim = $dmb->days_in_month($y,$m);
1647 @args = (1,1,$dim,31);
1648 }
1649
1650 when ('day_of_week') {
1651 @args = (0,1,7,7);
1652 }
1653 }
1654
1655 my($err,@vals) = $self->__rtime_values($val,@args);
1656 if ($err) {
1657 $$self{'err'} = "[dates] $err [$type]";
1658 return (1);
1659 }
1660 return(0,@vals);
1661}
1662
1663# This returns the raw values for a list.
1664#
1665# If $allowneg is 0, only positive numbers are allowed, and they must be
1666# in the range [$min,$absmax]. If $allowneg is 1, positive numbers in the
1667# range [$min,$absmax] and negative numbers in the range [-$absmax,-$min]
1668# are allowed. An error occurs if a value falls outside the range.
1669#
1670# Only values in the range of [$min,$max] are actually kept. This allows
1671# a recurrence for day_of_month to be 1-31 and not fail for a month that
1672# has fewer than 31 days. Any value outside the [$min,$max] are silently
1673# discarded.
1674#
1675# Returns:
1676# ($err,@vals)
1677#
1678sub __rtime_values {
1679 my($self,$vals,$allowneg,$min,$max,$absmax) = @_;
1680 my(@ret);
1681
1682 foreach my $val (@$vals) {
1683
1684 if (ref($val)) {
1685 my($val1,$val2) = @$val;
1686
1687 if ($allowneg) {
1688 return ('Value outside range')
1689 if ( ($val1 >= 0 && ($val1 < $min || $val1 > $absmax) ) ||
1690 ($val2 >= 0 && ($val2 < $min || $val2 > $absmax) ) );
1691 return ('Negative value outside range')
1692 if ( ($val1 <= 0 && ($val1 < -$absmax || $val1 > -$min) ) ||
1693 ($val2 <= 0 && ($val2 < -$absmax || $val2 > -$min) ) );
1694
1695 } else {
1696 return ('Value outside range')
1697 if ( ($val1 < $min || $val1 > $absmax) ||
1698 ($val2 < $min || $val2 > $absmax) );
1699
1700 }
1701
1702 return ('Range values reversed')
1703 if ( ($val1 <= 0 && $val2 <= 0 && $val1 > $val2) ||
1704 ($val1 >= 0 && $val2 >= 0 && $val1 > $val2) );
1705
1706 # Use $max instead of $absmax when converting negative numbers to
1707 # positive ones.
1708
1709 $val1 = $max + $val1 + 1 if ($val1 < 0); # day -10
1710 $val2 = $max + $val2 + 1 if ($val2 < 0);
1711
1712 $val1 = $min if ($val1 < $min); # day -31 in a 30 day month
1713 $val2 = $max if ($val2 > $max);
1714
1715 next if ($val1 > $val2);
1716
1717 push(@ret,$val1..$val2);
1718
1719 } else {
1720
1721 if ($allowneg) {
1722 return ('Value outside range')
1723 if ($val >= 0 && ($val < $min || $val > $absmax));
1724 return ('Negative value outside range')
1725 if ($val <= 0 && ($val < -$absmax || $val > -$min));
1726 } else {
1727 return ('Value outside range')
1728 if ($val < $min || $val > $absmax);
1729 }
1730
1731 # Use $max instead of $absmax when converting negative numbers to
1732 # positive ones.
1733
1734 my $ret;
1735 if ($val < 0 ) {
1736 $ret = $max + $val + 1;
1737 } else {
1738 $ret = $val;
1739 }
1740
1741 next if ($ret > $max || $ret < $min);
1742 push(@ret,$ret);
1743 }
1744 }
1745
1746 return ('',@ret);
1747}
1748
1749# This takes a list of dates (each a listref of [y,m,d,h,mn,s]) and replaces
1750# the Nth field with all of the possible values passed in, creating a new
1751# list with all the dates.
1752#
1753sub _field_add_values {
1754 my($self,$datesref,$n,@val) = @_;
1755
1756 my @dates = @$datesref;
1757 my @tmp;
1758
1759 foreach my $date (@dates) {
1760 my @d = @$date;
1761 foreach my $val (@val) {
1762 $d[$n] = $val;
1763 push(@tmp,[@d]);
1764 }
1765 }
1766
1767 @$datesref = @tmp;
1768}
1769
177016µs1;
1771# Local Variables:
1772# mode: cperl
1773# indent-tabs-mode: nil
1774# cperl-indent-level: 3
1775# cperl-continued-statement-offset: 2
1776# cperl-continued-brace-offset: 0
1777# cperl-brace-offset: 0
1778# cperl-brace-imaginary-offset: 0
1779# cperl-label-offset: -2
1780# End:
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.