package Date::Manip::Recur;
# Copyright (c) 1998-2018 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
########################################################################
# Any routine that starts with an underscore (_) is NOT intended for
# public use. They are for internal use in the the Date::Manip
# modules and are subject to change without warning or notice.
#
# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
########################################################################
use Date::Manip::Obj;
@ISA = ('Date::Manip::Obj');
require 5.010000;
use warnings;
use strict;
use integer;
use utf8;
use IO::File;
#use re 'debug';
use Date::Manip::Base;
use Date::Manip::TZ;
our $VERSION;
$VERSION='6.70';
END { undef $VERSION; }
########################################################################
# BASE METHODS
########################################################################
sub is_recur {
return 1;
}
# Call this every time a new recur is put in to make sure everything is
# correctly initialized.
#
sub _init {
my($self) = @_;
my $dmt = $$self{'tz'};
my $dmb = $$dmt{'base'};
$$self{'err'} = '';
$$self{'data'}{'freq'} = ''; # The frequency
$$self{'data'}{'flags'} = []; # Modifiers
$$self{'data'}{'base'} = undef; # The specified base date
$$self{'data'}{'BASE'} = undef; # The actual base date
$$self{'data'}{'start'} = undef; # Start and end date
$$self{'data'}{'end'} = undef;
$$self{'data'}{'unmod_range'} = 0; # If this is 1, the start/end range
# refer to the unmodified dates, not the
# final dates.
$$self{'data'}{'interval'} = []; # (Y, M, ...)
$$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
# [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
# ... )
$$self{'data'}{'slow'} = 0; # 1 if a range of the form 2--2 is
# included.
$$self{'data'}{'ev_per_d'} = 0; # The number of events per interval date.
$$self{'data'}{'delta'} = undef; # The offset based on the interval.
$$self{'data'}{'noint'} = 1; # 0 if an interval is present
# 1 if no interval is present and dates
# not done
# 2 if no interval is present and dates
# done
$$self{'data'}{'idate'} = {}; # Non-slow:
# { N => Nth interval date }
# Slow:
# { N => [Nth interval date,X,Y] }
# [X,Y] are the first/last event indices
# generated by this interval date.
$$self{'data'}{'dates'} = {}; # { N => Nth recurring event }
# N is relative to the base date and is
# not affected by start/end
$$self{'data'}{'curr'} = undef; # Iterator pointer
$$self{'data'}{'first'} = undef; # N : the first date in a range
$$self{'data'}{'last'} = undef; # N : the last date in a range
# Get the default start/end dates
my $range = $dmb->_config('recurrange');
if ($range eq 'none') {
$$self{'data'}{'start'} = undef;
$$self{'data'}{'end'} = undef;
} elsif ($range eq 'year') {
my $y = $dmt->_now('y',1);
my $start = $self->new_date();
my $end = $self->new_date();
$start->set('date',[$y, 1, 1,00,00,00]);
$end->set ('date',[$y,12,31,23,59,59]);
$$self{'data'}{'start'} = $start;
$$self{'data'}{'end'} = $end;
} elsif ($range eq 'month') {
my ($y,$m) = $dmt->_now('now',1);
my $dim = $dmb->days_in_month($y,$m);
my $start = $self->new_date();
my $end = $self->new_date();
$start->set('date',[$y,$m, 1,00,00,00]);
$end->set ('date',[$y,$m,$dim,23,59,59]);
$$self{'data'}{'start'} = $start;
$$self{'data'}{'end'} = $end;
} elsif ($range eq 'week') {
my($y,$m,$d) = $dmt->_now('now',1);
my $w;
($y,$w) = $dmb->week_of_year([$y,$m,$d]);
($y,$m,$d) = @{ $dmb->week_of_year($y,$w) };
my($yy,$mm,$dd)
= @{ $dmb->_calc_date_ymwd([$y,$m,$d], [0,0,0,6], 0) };
my $start = $self->new_date();
my $end = $self->new_date();
$start->set('date',[$y, $m, $d, 00,00,00]);
$end->set ('date',[$yy,$mm,$dd,23,59,59]);
$$self{'data'}{'start'} = $start;
$$self{'data'}{'end'} = $end;
} elsif ($range eq 'day') {
my($y,$m,$d) = $dmt->_now('now',1);
my $start = $self->new_date();
my $end = $self->new_date();
$start->set('date',[$y,$m,$d,00,00,00]);
$end->set ('date',[$y,$m,$d,23,59,59]);
$$self{'data'}{'start'} = $start;
$$self{'data'}{'end'} = $end;
} elsif ($range eq 'all') {
my $start = $self->new_date();
my $end = $self->new_date();
$start->set('date',[0001,02,01,00,00,00]);
$end->set ('date',[9999,11,30,23,59,59]);
$$self{'data'}{'start'} = $start;
$$self{'data'}{'end'} = $end;
}
}
# If $keep is 1, it will keep any existing base date and cached
# dates, but it will reset other things.
#
sub _init_dates {
my($self,$keep) = @_;
if (! $keep) {
$$self{'data'}{'base'} = undef;
$$self{'data'}{'BASE'} = undef;
$$self{'data'}{'idate'} = {};
$$self{'data'}{'dates'} = {};
}
$$self{'data'}{'curr'} = undef;
$$self{'data'}{'first'} = undef;
$$self{'data'}{'last'} = undef;
}
sub _init_args {
my($self) = @_;
my @args = @{ $$self{'args'} };
$self->parse(@args);
}
########################################################################
# METHODS
########################################################################
sub parse {
my($self,$string,@args) = @_;
$self->_init();
# Test if $string = FREQ
my $err = $self->frequency($string);
if (! $err) {
$string = '';
}
# Test if $string = "FREQ*..." and FREQ contains an '*'.
if ($err) {
$self->err(1);
$string =~ s/\s*\*\s*/\*/g;
if ($string =~ /^([^*]*\*[^*]*)\*/) {
# Everything up to the 2nd '*'
my $freq = $1;
$err = $self->frequency($freq);
if (! $err) {
$string =~ s/^\Q$freq\E\*//;
}
} else {
$err = 1;
}
}
# Test if $string = "FREQ*..." and FREQ does NOT contains an '*'.
if ($err) {
$self->err(1);
if ($string =~ s/^([^*]*)\*//) {
# Everything up to he 1st '*'
my $freq = $1;
$err = $self->frequency($freq);
if (! $err) {
$string =~ s/^\Q$freq\E\*//;
}
} else {
$err = 1;
}
}
if ($err) {
$$self{'err'} = "[parse] Invalid frequency string";
return 1;
}
# Handle MODIFIERS from string and arguments
my @string = split(/\*/,$string);
if (@string) {
my $tmp = shift(@string);
$err = $self->modifiers($tmp) if ($tmp);
return 1 if ($err);
}
if (@args) {
my $tmp = $args[0];
if ($tmp && ! ref($tmp)) {
$err = $self->modifiers($tmp);
shift(@args) if (! $err);
}
}
# Handle BASE
if (@string) {
my $tmp = shift(@string);
$err = $self->basedate($tmp) if (defined($tmp) && $tmp);
return 1 if ($err);
}
if (@args) {
my $tmp = shift(@args);
$err = $self->basedate($tmp) if (defined($tmp) && $tmp);
return 1 if ($err);
}
# Handle START, END, UNMOD
if (@string) {
my($start) = shift(@string);
my($end) = shift(@string);
my($unmod) = shift(@string);
$err = $self->start($start,$unmod) if (defined($start) && $start);
return 1 if ($err);
$err = $self->end($end) if (defined($end) && $end);
return 1 if ($err);
}
if (@args) {
my($start) = shift(@args);
my($end) = shift(@args);
my($unmod) = shift(@args);
$err = $self->start($start,$unmod) if (defined($start) && $start);
return 1 if ($err);
$err = $self->end($end) if (defined($end) && $end);
return 1 if ($err);
}
# Remaining arguments are invalid.
if (@string) {
$$self{'err'} = "[parse] String contains invalid elements";
return 1;
}
if (@args) {
$$self{'err'} = "[parse] Unknown arguments";
return 1;
}
return 0;
}
sub frequency {
my($self,$string) = @_;
return $$self{'data'}{'freq'} if (! defined $string);
$self->_init();
my (@int,@rtime);
PARSE: {
# Standard frequency notation
my $stdrx = $self->_rx('std');
if ($string =~ $stdrx) {
my($l,$r) = @+{qw(l r)};
if (defined($l)) {
$l =~ s/^\s*:/0:/;
$l =~ s/:\s*$/:0/;
$l =~ s/::/:0:/g;
@int = split(/:/,$l);
}
if (defined($r)) {
$r =~ s/^\s*:/0:/;
$r =~ s/:\s*$/:0/;
$r =~ s/::/:0:/g;
@rtime = split(/:/,$r);
}
last PARSE;
}
# Other frequency strings
# Strip out some words to ignore
my $ignrx = $self->_rx('ignore');
$string =~ s/$ignrx/ /g;
my $eachrx = $self->_rx('each');
my $each = 0;
if ($string =~ s/$eachrx/ /g) {
$each = 1;
}
$string =~ s/\s*$//;
if (! $string) {
$$self{'err'} = "[frequency] Invalid frequency string";
return 1;
}
my($l,$r);
my $err = $self->_parse_lang($string);
if ($err) {
$$self{'err'} = "[frequency] Invalid frequency string";
return 1;
}
return 0;
}
# If the interval consists only of zeros, the last entry is changed
# to 1.
if (@int) {
for my $i (@int) {
$i += 0;
}
TEST_INT: {
for my $i (@int) {
last TEST_INT if ($i);
}
$int[$#int] = 1;
}
}
# If @int contains 2 or 3 elements and ends in 0, move the trailing
# 0 to the start of @rtime.
#
# Y:M:0 * D:H:MN:S => Y:M * 0:D:H:MN:S
while (@int &&
($#int == 1 || $#int == 2) &&
($int[$#int] == 0)) {
pop(@int);
unshift(@rtime,0);
}
# We need to know what the valid values of M, W, and D are.
#
# Month can be:
# moy : 1 to 12 (month of the year)
#
# Week can be:
# woy : 1 to 53 or -1 to -53 (week of the year)
# wom : 1 to 5 or -1 to -5 (week of the month)
#
# Day can be:
# doy : 1 to 366 or -1 to -366 (day of the year)
# dom : 1 to 31 or -1 to -31 (day of the month)
# dow : 1 to 7 (day of the week)
#
# Other values must be zero or positive.
my($mtype,$wtype,$dtype) = ('','','');
my @f = (@int,@rtime);
my $m = $f[1];
my $w = $f[2];
my $d = $f[3];
if ($d && @int < 4) {
if ($w) {
$dtype = 'dow';
} elsif ($m) {
$dtype = 'dom';
} else {
$dtype = 'doy';
}
}
if ($w && @int < 3) {
if ($m) {
$wtype = 'wom';
} else {
$wtype = 'woy';
}
}
if ($m && @int < 2) {
$mtype = 'moy';
}
# Test the format of @rtime.
#
# Turn it to:
# @rtime = ( NUM|RANGE, NUM|RANGE, ...)
# where
# NUM is an integer
# RANGE is [NUM1,NUM2]
my $rfieldrx = $self->_rx('rfield');
my $rrangerx = $self->_rx('rrange');
my @type = qw(y m w d h mn s);
while ($#type > $#rtime) {
shift(@type);
}
foreach my $rfield (@rtime) {
my $type = shift(@type);
if ($rfield !~ $rfieldrx) {
$$self{'err'} = "[frequency] Invalid rtime string";
return 1;
}
my @rfield = split(/,/,$rfield);
my @val;
foreach my $vals (@rfield) {
if ($vals =~ $rrangerx) {
my ($num1,$num2) = ($1+0,$2+0);
my $err = $self->_frequency_values($num1,$type,$mtype,$wtype,$dtype);
return $err if ($err);
$err = $self->_frequency_values($num2,$type,$mtype,$wtype,$dtype);
return $err if ($err);
if ( ($num1 > 0 && $num2 > 0) ||
($num1 < 0 && $num2 < 0) ) {
if ($num1 > $num2) {
$$self{'err'} = "[frequency] Invalid rtime range string";
return 1;
}
push(@val,$num1..$num2);
} else {
push(@val,[$num1,$num2]);
}
} else {
$vals += 0;
my $err = $self->_frequency_values($vals,$type,$mtype,$wtype,$dtype);
return $err if ($err);
push(@val,$vals);
}
}
$rfield = [ @val ];
}
# Store it
$$self{'data'}{'interval'} = [ @int ];
$$self{'data'}{'rtime'} = [ @rtime ];
# Analyze the rtime to see if it's slow, and to get the number of
# events per interval date.
my $freq = join(':',@int);
my $slow = 0;
my $n = 1;
if (@rtime) {
$freq .= '*';
my (@tmp);
foreach my $rtime (@rtime) {
my @t2;
foreach my $tmp (@$rtime) {
if (ref($tmp)) {
my($a,$b) = @$tmp;
push(@t2,"$a-$b");
$slow = 1;
} else {
push(@t2,$tmp);
}
}
my $tmp = join(',',@t2);
push(@tmp,$tmp);
my $nn = @t2;
$n *= $nn;
}
$freq .= join(':',@tmp);
}
$$self{'data'}{'freq'} = $freq;
$$self{'data'}{'slow'} = $slow;
$$self{'data'}{'ev_per_d'} = $n if (! $slow);
if (@int) {
$$self{'data'}{'noint'} = 0;
while (@int < 7) {
push(@int,0);
}
my $delta = $self->new_delta();
$delta->set('delta',[@int]);
$$self{'data'}{'delta'} = $delta;
} else {
$$self{'data'}{'noint'} = 1;
}
return 0;
}
sub _frequency_values {
my($self,$num,$type,$mtype,$wtype,$dtype) = @_;
my $err;
if ($type eq 'm') {
if ($mtype eq 'moy') {
if ($num < 1) {
$$self{'err'} = "[frequency] Month of year must be 1-12 (zero/negative not allowed)";
return 1;
} elsif ($num > 12) {
$$self{'err'} = "[frequency] Month of year must be 1-12";
return 1;
}
}
return 0;
}
if ($type eq 'w') {
if ($wtype eq 'woy') {
if ($num == 0) {
$$self{'err'} = "[frequency] Week of year must be nonzero";
return 1;
} elsif ($num > 53 || $num < -53) {
$$self{'err'} = "[frequency] Week of year must be 1-53 or -1 to -53";
return 1;
}
} elsif ($wtype eq 'wom') {
if ($num == 0) {
$$self{'err'} = "[frequency] Week of month must be nonzero";
return 1;
} elsif ($num > 5 || $num < -5) {
$$self{'err'} = "[frequency] Week of month must be 1-5 or -1 to -5";
return 1;
}
}
return 0;
}
if ($type eq 'd') {
if ($dtype eq 'dow') {
if ($num < 1) {
$$self{'err'} = "[frequency] Day of week must be 1-7 (zero/negative not allowed)";
return 1;
} elsif ($num > 7) {
$$self{'err'} = "[frequency] Day of week must be 1-7";
return 1;
}
} elsif ($dtype eq 'dom') {
if ($num == 0) {
$$self{'err'} = "[frequency] Day of month must be nonzero";
return 1;
} elsif ($num > 31 || $num < -31) {
$$self{'err'} = "[frequency] Day of month must be 1-31 or -1 to -31";
return 1;
}
} elsif ($dtype eq 'doy') {
if ($num == 0) {
$$self{'err'} = "[frequency] Day of year must be nonzero";
return 1;
} elsif ($num > 366 || $num < -366) {
$$self{'err'} = "[frequency] Day of year must be 1-366 or -1 to -366";
return 1;
}
}
return 0;
}
if ($num < 0) {
$$self{'err'} = "[frequency] Negative values only allowed for day/week";
return 1;
}
return 0;
}
sub _parse_lang {
my($self,$string) = @_;
my $dmt = $$self{'tz'};
my $dmb = $$dmt{'base'};
# Test the regular expression
my $rx = $self->_rx('every');
return 1 if ($string !~ $rx);
my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) =
@+{qw(month week day last nth day_name day_abb mon_name mon_abb n y)};
# Convert wordlist values to calendar values
my $dow;
if (defined($day_name) || defined($day_abb)) {
if (defined($day_name)) {
$dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{lc($day_name)};
} else {
$dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{lc($day_abb)};
}
}
my $mmm;
if (defined($mon_name) || defined($mon_abb)) {
if (defined($mon_name)) {
$mmm = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($mon_name)};
} else {
$mmm = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mon_abb)};
}
}
if (defined($nth)) {
$nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
}
# Get the frequencies
my($freq);
if (defined($dow)) {
if (defined($mmm)) {
if (defined($last)) {
# last DoW in MMM [YY]
$freq = "1*$mmm:-1:$dow:0:0:0";
} elsif (defined($nth)) {
# Nth DoW in MMM [YY]
$freq = "1*$mmm:$nth:$dow:0:0:0";
} else {
# every DoW in MMM [YY]
$freq = "1*$mmm:1-5:$dow:0:0:0";
}
} else {
if (defined($last)) {
# last DoW in every month [in YY]
$freq = "0:1*-1:$dow:0:0:0";
} elsif (defined($nth)) {
# Nth DoW in every month [in YY]
$freq = "0:1*$nth:$dow:0:0:0";
} else {
# every DoW in every month [in YY]
$freq = "0:1*1-5:$dow:0:0:0";
}
}
} elsif (defined($day)) {
if (defined($month)) {
if (defined($nth)) {
# Nth day of every month [YY]
$freq = "0:1*0:$nth:0:0:0";
} elsif (defined($last)) {
# last day of every month [YY]
$freq = "0:1*0:-1:0:0:0";
} else {
# every day of every month [YY]
$freq = "0:0:0:1*0:0:0";
}
} else {
if (defined($nth)) {
# every Nth day [YY]
$freq = "0:0:0:$nth*0:0:0";
} elsif (defined($n)) {
# every N days [YY]
$freq = "0:0:0:$n*0:0:0";
} else {
# every day [YY]
$freq = "0:0:0:1*0:0:0";
}
}
}
# Get the range (if YY is included)
if (defined($y)) {
$y = $dmt->_fix_year($y);
my $start = "${y}010100:00:00";
my $end = "${y}123123:59:59";
return $self->parse($freq,undef,$start,$end);
}
return $self->frequency($freq)
}
sub _date {
my($self,$op,$date_or_string) = @_;
# Make sure the argument is a date
if (ref($date_or_string) eq 'Date::Manip::Date') {
$$self{'data'}{$op} = $date_or_string;
} elsif (ref($date_or_string)) {
$$self{'err'} = "[$op] Invalid date object";
return 1;
} else {
my $date = $self->new_date();
my $err = $date->parse($date_or_string);
if ($err) {
$$self{'err'} = "[$op] Invalid date string";
return 1;
}
$$self{'data'}{$op} = $date;
}
return 0;
}
sub start {
my($self,$start,$unmod) = @_;
return $$self{'data'}{'start'} if (! defined $start);
$self->_init_dates(1);
$$self{'data'}{'unmod_range'} = $unmod;
$self->_date('start',$start);
}
sub end {
my($self,$end) = @_;
return $$self{'data'}{'end'} if (! defined $end);
$self->_init_dates(1);
$self->_date('end',$end);
}
sub basedate {
my($self,$base) = @_;
return ($$self{'data'}{'base'},$$self{'data'}{'BASE'}) if (! defined $base);
$self->_init_dates();
$self->_date('base',$base);
}
sub modifiers {
my($self,@flags) = @_;
return @{ $$self{'data'}{'flags'} } if (! @flags);
my $dmt = $$self{'tz'};
my $dmb = $$dmt{'base'};
if (@flags == 1) {
@flags = split(/,/,lc($flags[0]));
}
# Add these flags to the list
if (@flags && $flags[0] eq "+") {
shift(@flags);
my @tmp = @{ $$self{'data'}{'flags'} };
@flags = (@tmp,@flags) if (@tmp);
}
# Return an error if any modifier is unknown
foreach my $flag (@flags) {
next if ($flag =~ /^([pn][dt][1-7]|wd[1-7]|[fb][dw]\d+|cw[dnp]|[npd]wd|[in]bd|[in]w[1-7]|easter)$/);
$$self{'err'} = "[modifiers] Invalid modifier: $flag";
return 1;
}
$$self{'data'}{'flags'} = [ @flags ];
$self->_init_dates();
return 0;
}
sub nth {
my($self,$n) = @_;
$n = 0 if (! $n);
return ($$self{'data'}{'dates'}{$n},0)
if (exists $$self{'data'}{'dates'}{$n});
my ($err) = $self->_error();
return (undef,$err) if ($err);
return ($$self{'data'}{'dates'}{$n},0)
if (exists $$self{'data'}{'dates'}{$n});
# If there is no interval, then we've found every date that
# can be found.
if ($$self{'data'}{'noint'}) {
return (undef,0);
}
if ($$self{'data'}{'slow'}) {
my $nn = 0;
while (1) {
$self->_nth_interval($nn);
return ($$self{'data'}{'dates'}{$n},0)
if (exists $$self{'data'}{'dates'}{$n});
if ($n >= 0) {
$nn++;
} else {
$nn--;
}
}
} else {
my $nn;
if ($n >= 0) {
$nn = int($n/$$self{'data'}{'ev_per_d'});
} else {
$nn = int(($n+1)/$$self{'data'}{'ev_per_d'}) -1;
}
$self->_nth_interval($nn);
return ($$self{'data'}{'dates'}{$n},0);
}
}
sub next {
my($self) = @_;
my ($err) = $self->_error();
return (undef,$err) if ($err);
# If curr is not set, we have to get it.
if (! defined $$self{'data'}{'curr'}) {
CURR:
while (1) {
# If no interval then
# return base date
if ($$self{'data'}{'noint'}) {
$$self{'data'}{'curr'} = -1;
last CURR;
}
# If a range is defined
# find first event in range and return it
if (defined $$self{'data'}{'start'} &&
defined $$self{'data'}{'end'}) {
my $n = $self->_locate_n('first');
$$self{'data'}{'curr'} = $n-1;
} else {
$$self{'data'}{'curr'} = -1;
}
last CURR;
}
}
# With curr set, find the next defined one
while (1) {
$$self{'data'}{'curr'}++;
if ($$self{'data'}{'noint'}) {
return (undef,0)
if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
}
my ($d,$e) = $self->nth($$self{'data'}{'curr'});
return (undef,$e) if ($e);
return ($d,0) if (defined $d);
}
}
sub prev {
my($self) = @_;
my ($err) = $self->_error();
return (undef,$err) if ($err);
# If curr is not set, we have to get it.
if (! defined $$self{'data'}{'curr'}) {
CURR:
while (1) {
# If no interval then
# return last one
if ($$self{'data'}{'noint'}) {
my @n = sort { $a <=> $b } keys %{ $$self{'data'}{'dates'} };
$$self{'data'}{'curr'} = pop(@n) + 1;
last CURR;
}
# If a range is defined
# find last event in range and return it
if (defined $$self{'data'}{'start'} &&
defined $$self{'data'}{'end'}) {
my $n = $self->_locate_n('last');
$$self{'data'}{'curr'} = $n+1;
} else {
$$self{'data'}{'curr'} = 0;
}
last CURR;
}
}
# With curr set, find the previous defined one
while (1) {
$$self{'data'}{'curr'}--;
if ($$self{'data'}{'noint'}) {
return (undef,0)
if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
}
my ($d,$e) = $self->nth($$self{'data'}{'curr'});
return (undef,$e) if ($e);
return ($d,0) if (defined $d);
}
}
sub dates {
my($self,$start2,$end2,$unmod) = @_;
$self->err(1);
# If $start2 or $end2 are provided, make sure they are valid.
# If either are provided, make a note of it ($tmp_limits).
my $tmp_limits = 0;
$tmp_limits = 1 if ($start2 || $end2);
$unmod = 0 if (! $unmod);
# Check the recurrence for errors. If both $start2 and $end2 are
# provided, it's not necessary for a range to be in the recurrence.
my $range_required;
if (defined($start2) && defined($end2)) {
$range_required = 0;
} else {
$range_required = 1;
}
my($err);
($err,$start2,$end2) = $self->_error($range_required,$start2,$end2);
return () if ($err);
# If $start2 or $end2 were provided, back up the data that applies
# to the current date range, and store the new date range in it's place.
my ($old_start, $old_end, $old_first, $old_last, $old_unmod);
if ($tmp_limits) {
$old_start = $$self{'data'}{'start'};
$old_end = $$self{'data'}{'end'};
$old_first = $$self{'data'}{'first'};
$old_last = $$self{'data'}{'last'};
$old_unmod = $$self{'data'}{'unmod_range'};
$$self{'data'}{'start'} = $start2;
$$self{'data'}{'end'} = $end2;
$$self{'data'}{'first'} = undef;
$$self{'data'}{'last'} = undef;
$$self{'data'}{'unmod_range'} = $unmod;
}
# Get all of the dates
my($end,$first,$last,@dates);
$first = $self->_locate_n('first');
$last = $self->_locate_n('last');
if (defined($first) && defined($last)) {
for (my $n = $first; $n <= $last; $n++) {
my($date,$err) = $self->nth($n);
push(@dates,$date) if (defined $date);
}
}
# Restore the original date range values.
if ($tmp_limits) {
$$self{'data'}{'start'} = $old_start;
$$self{'data'}{'end'} = $old_end;
$$self{'data'}{'first'} = $old_first;
$$self{'data'}{'last'} = $old_last;
$$self{'data'}{'unmod_range'} = $old_unmod;
}
return @dates;
}
########################################################################
# MISC
########################################################################
# This checks a recurrence for errors and completeness prior to
# extracting a date or dates from it.
#
sub _error {
my($self,$range_required,$start2,$end2) = @_;
return ('Invalid recurrence') if ($self->err());
# All dates entered must be valid.
my($start,$end);
if (defined $start2) {
if (ref($start2) eq 'Date::Manip::Date') {
$start = $start2;
} elsif (! ref($start2)) {
$start = $self->new_date();
$start->parse($start2);
} else {
return ('Invalid start argument');
}
return ('Start invalid') if ($start->err());
} elsif (defined $$self{'data'}{'start'}) {
$start = $$self{'data'}{'start'};
return ('Start invalid') if ($start->err());
}
if (defined $end2) {
if (ref($end2) eq 'Date::Manip::Date') {
$end = $end2;
} elsif (! ref($end2)) {
$end = $self->new_date();
$end->parse($end2);
} else {
return ('Invalid end argument');
}
return ('End invalid') if ($end->err());
} elsif (defined $$self{'data'}{'end'}) {
$end = $$self{'data'}{'end'};
return ('End invalid') if ($end->err());
}
if (defined $$self{'data'}{'base'}) {
my $base = $$self{'data'}{'base'};
return ('Base invalid') if ($base->err());
}
# *Y:M:W:D:H:MN:S is complete.
if ($$self{'data'}{'noint'}) {
if ($$self{'data'}{'noint'} == 1) {
my @dates = $self->_apply_rtime_mods();
$$self{'data'}{'noint'} = 2;
my $n = 0;
foreach my $date (@dates) {
next if (! defined $date);
$$self{'data'}{'dates'}{$n++} = $date;
}
return (0,$start,$end) if ($n == 0);
if (defined $start && defined $end) {
my ($first,$last);
for (my $i=0; $i<$n; $i++) {
my $date = $$self{'data'}{'dates'}{$i};
if ($start->cmp($date) <= 0 &&
$end->cmp($date) >= 0) {
$first = $i;
last;
}
}
for (my $i=$n-1; $i>=0; $i--) {
my $date = $$self{'data'}{'dates'}{$i};
if ($start->cmp($date) <= 0 &&
$end->cmp($date) >= 0) {
$last = $i;
last;
}
}
$$self{'data'}{'first'} = $first;
$$self{'data'}{'last'} = $last;
} else {
$$self{'data'}{'first'} = 0;
$$self{'data'}{'last'} = $n-1;
}
}
return (0,$start,$end);
}
# If a range is entered, it must be valid. Also
# a range is required if $range_required is given.
if ($start && $end) {
return ('Range invalid') if ($start->cmp($end) == 1);
} elsif ($range_required) {
return ('Incomplete recurrence');
}
# Check that the base date is available.
$self->_actual_base($start);
if (defined $$self{'data'}{'BASE'}) {
my $base = $$self{'data'}{'BASE'};
return ('Base invalid') if ($base->err());
return (0,$start,$end);
}
return ('Incomplete recurrence');
}
# This determines the actual base date from a specified base date (or
# start date). If a base date cannot be set, then
# $$self{'data'}{'BASE'} is NOT defined.
#
sub _actual_base {
my($self,$start2) = @_;
# Is the actual base date already defined?
return if (defined $$self{'data'}{'BASE'});
# Use the specified base date or start date.
my $base = undef;
if (defined $$self{'data'}{'base'}) {
$base = $$self{'data'}{'base'};
} elsif (defined $start2) {
$base = $start2;
} elsif (defined $$self{'data'}{'start'}) {
$base = $$self{'data'}{'start'};
} else {
return;
}
# Determine the actual base date from the specified base date.
my $dmt = $$self{'tz'};
my $dmb = $$dmt{'base'};
$dmt->_update_now(); # Update NOW
my @int = @{ $$self{'data'}{'interval'} };
my @rtime = @{ $$self{'data'}{'rtime'} };
my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
my ($y,$m,$d,$h,$mn,$s) = $base->value();
my $BASE = $self->new_date();
my $n = @int;
if ($n == 0) {
# *Y:M:W:D:H:MN:S
return;
} elsif ($n == 1) {
# Y*M:W:D:H:MN:S
$BASE->set('date',[$y,1,1,0,0,0]);
} elsif ($n == 2) {
# Y:M*W:D:H:MN:S
$BASE->set('date',[$y,$m,1,0,0,0]);
} elsif ($n == 3) {
# Y:M:W*D:H:MN:S
my($yy,$w) = $dmb->week_of_year([$y,$m,$d,$h,$mn,$s]);
my($ymd) = $dmb->week_of_year($yy,$w);
$BASE->set('date',[@$ymd,0,0,0]);
} elsif ($n == 4) {
# Y:M:W:D*H:MN:S
$BASE->set('date',[$y,$m,$d,0,0,0]);
} elsif ($n == 5) {
# Y:M:W:D:H*MN:S
$BASE->set('date',[$y,$m,$d,$h,0,0]);
} elsif ($n == 6) {
# Y:M:W:D:H:MN*S
$BASE->set('date',[$y,$m,$d,$h,$mn,0]);
} else {
# Y:M:W:D:H:MN:S
$BASE->set('date',[$y,$m,$d,$h,$mn,$s]);
}
$$self{'data'}{'BASE'} = $BASE;
}
sub _rx {
my($self,$rx) = @_;
my $dmt = $$self{'tz'};
my $dmb = $$dmt{'base'};
return $$dmb{'data'}{'rx'}{'recur'}{$rx}
if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx});
if ($rx eq 'std') {
my $l = '[0-9]*';
my $r = '[-,0-9]*';
my $stdrx = "(?<l>$l:$l:$l:$l:$l:$l:$l)(?<r>)|" .
"(?<l>$l:$l:$l:$l:$l:$l)\\*(?<r>$r)|" .
"(?<l>$l:$l:$l:$l:$l)\\*(?<r>$r:$r)|" .
"(?<l>$l:$l:$l:$l)\\*(?<r>$r:$r:$r)|" .
"(?<l>$l:$l:$l)\\*(?<r>$r:$r:$r:$r)|" .
"(?<l>$l:$l)\\*(?<r>$r:$r:$r:$r:$r)|" .
"(?<l>$l)\\*(?<r>$r:$r:$r:$r:$r:$r)|" .
"(?<l>)\\*(?<r>$r:$r:$r:$r:$r:$r:$r)";
$$dmb{'data'}{'rx'}{'recur'}{$rx} = qr/^\s*(?:$stdrx)\s*$/;
} elsif ($rx eq 'rfield' ||
$rx eq 'rnum' ||
$rx eq 'rrange') {
my $num = '[+-]?\d+';
my $range = "$num\-$num";
my $val = "(?:$range|$num)";
my $vals = "$val(?:,$val)*";
$$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/;
$$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/;
$$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/;
} elsif ($rx eq 'each') {
my $each = $$dmb{'data'}{'rx'}{'each'};
my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i;
$$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx;
} elsif ($rx eq 'ignore') {
my $of = $$dmb{'data'}{'rx'}{'of'};
my $on = $$dmb{'data'}{'rx'}{'on'};
my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i;
$$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx;
} elsif ($rx eq 'every') {
my $month = $$dmb{'data'}{'rx'}{'fields'}[2];
my $week = $$dmb{'data'}{'rx'}{'fields'}[3];
my $day = $$dmb{'data'}{'rx'}{'fields'}[4];
my $last = $$dmb{'data'}{'rx'}{'last'};
my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0];
my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0];
my $beg = '(?:^|\s+)';
my $end = '(?:\s*$)';
$month = "$beg(?<month>$month)"; # months
$week = "$beg(?<week>$week)"; # weeks
$day = "$beg(?<day>$day)"; # days
$last = "$beg(?<last>$last)"; # last
$nth = "$beg(?<nth>$nth)"; # 1st,2nd,...
$nth_wom = "$beg(?<nth>$nth_wom)"; # 1st - 5th
$nth_dom = "$beg(?<nth>$nth_dom)"; # 1st - 31st
my $n = "$beg(?<n>\\d+)"; # 1,2,...
my $dow = "$beg(?:(?<day_name>$day_name)|(?<day_abb>$day_abb))"; # Sun|Sunday
my $mmm = "$beg(?:(?<mon_name>$mon_name)|(?<mon_abb>$mon_abb))"; # Jan|January
my $y = "(?:$beg(?:(?<y>\\d\\d\\d\\d)|(?<y>\\d\\d)))?";
my $freqrx =
"$nth_wom?$dow$mmm$y|" . # every DoW in MMM [YY]
"$last$dow$mmm$y|" . # Nth DoW in MMM [YY]
# last DoW in MMM [YY]
# day_name|day_abb
# mon_name|mon_abb
# last*|nth*
# y*
"$nth_wom?$dow$month$y|" . # every DoW of every month [YY]
"$last$dow$month$y|" . # Nth DoW of every month [YY]
# last DoW of every month [YY]
# day_name|day_abb
# last*|nth*
# y*
"$nth_dom?$day$month$y|" . # every day of every month [YY]
"$last$day$month$y|" . # Nth day of every month [YY]
# last day of every month [YY]
# day
# month
# nth*|last*
# y*
"$nth*$day$y|" . # every day [YY]
"$n$day$y"; # every Nth day [YY]
# every N days [YY]
# day
# nth*|n*
# y*
$freqrx = qr/^(?:$freqrx)\s*$/i;
$$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx;
}
return $$dmb{'data'}{'rx'}{'recur'}{$rx};
}
# @dates = $self->_apply_rtime_mods();
#
# Should only be called if there is no interval (*Y:M:W:D:H:MN:S).
#
# It will use rtime/modifiers to get a list of all events
# specified by the recurrence. This only needs to be done once.
#
# @dates = $self->_apply_rtime_mods($date);
#
# For all other types of recurrences, this will take a single
# date and apply all rtime/modifiers to it to get a list of
# events.
#
sub _apply_rtime_mods {
my($self,$date) = @_;
my $dmt = $$self{'tz'};
my $dmb = $$dmt{'base'};
my @int = @{ $$self{'data'}{'interval'} };
my @rtime = @{ $$self{'data'}{'rtime'} };
my $n = @int;
my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
my $m_empty = $self->_field_empty($mf);
my $w_empty = $self->_field_empty($wf);
my $d_empty = $self->_field_empty($df);
my ($err,$y,$m,$d,$h,$mn,$s,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n);
($y,$m,$d,$h,$mn,$s) = $date->value() if (defined $date);
my(@date);
if ($n <= 1) {
#
# *Y:M:W:D:H:MN:S
# Y*M:W:D:H:MN:S
#
if (@int == 0) {
($err,@y) = $self->_rtime_values('y',$yf);
return () if ($err);
} else {
@y = ($y);
}
if ( ($m_empty && $w_empty && $d_empty) ||
(! $m_empty && $w_empty) ) {
# *0:0:0:0 Jan 1 of the current year
# *1:0:0:0 Jan 1, 0001
# *0:2:0:0 Feb 1 of the current year
# *1:2:0:0 Feb 1, 0001
# *0:2:0:4 Feb 4th of the current year
# *1:2:0:4 Feb 4th, 0001
# 1*0:0:0 every year on Jan 1
# 1*2:0:0 every year on Feb 1
# 1*2:0:4 every year on Feb 4th
$mf = [1] if ($m_empty);
$df = [1] if ($d_empty);
($err,@m) = $self->_rtime_values('m',$mf);
return () if ($err);
foreach my $y (@y) {
foreach my $m (@m) {
($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
return () if ($err);
foreach my $d (@d) {
push(@date,[$y,$m,$d,0,0,0]);
}
}
}
} elsif ($m_empty) {
if ($w_empty) {
# *0:0:0:4 the 4th day of the current year
# *1:0:0:4 the 4th day of 0001
# 1*0:0:4 every year on the 4th day of the year
foreach my $y (@y) {
($err,@doy) = $self->_rtime_values('day_of_year',$df,$y);
return () if ($err);
foreach my $doy (@doy) {
my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) };
push(@date,[$yy,$mm,$dd,0,0,0]);
}
}
} elsif ($d_empty) {
# *0:0:3:0 the first day of the 3rd week of the curr year
# *1:0:3:0 the first day of the 3rd week of 0001
# 1*0:3:0 every year on the first day of 3rd week of year
foreach my $y (@y) {
($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y);
return () if ($err);
foreach my $woy (@woy) {
my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) };
push(@date,[$yy,$mm,$dd,0,0,0]);
}
}
} else {
# *1:0:3:4 in 0001 on the 3rd Thur of the year
# *0:0:3:4 on the 3rd Thur of the current year
# 1*0:3:4 every year on the 3rd Thur of the year
($err,@dow) = $self->_rtime_values('day_of_week',$df);
return () if ($err);
foreach my $y (@y) {
foreach my $dow (@dow) {
($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow);
return () if ($err);
foreach my $n (@n) {
my $ymd = $dmb->nth_day_of_week($y,$n,$dow);
my($yy,$mm,$dd) = @$ymd;
push(@date,[$yy,$mm,$dd,0,0,0]);
}
}
}
}
} else {
# *1:2:3:4 in Feb 0001 on the 3rd Thur of the month
# *0:2:3:4 on the 3rd Thur of Feb in the curr year
# *1:2:3:0 the 3rd occurrence of FirstDay in Feb 0001
# *0:2:3:0 the 3rd occurrence of FirstDay in Feb of curr year
# 1*2:3:4 every year in Feb on the 3rd Thur
# 1*2:3:0 every year on the 3rd occurrence of FirstDay in Feb
($err,@m) = $self->_rtime_values('m',$mf);
return () if ($err);
if ($d_empty) {
@dow = ($dmb->_config('firstday'));
} else {
($err,@dow) = $self->_rtime_values('day_of_week',$df);
return () if ($err);
}
foreach my $y (@y) {
foreach my $m (@m) {
foreach my $dow (@dow) {
($err,@n) = $self->_rtime_values('dow_of_month',
$wf,$y,$m,$dow);
return () if ($err);
foreach my $n (@n) {
my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
my($yy,$mm,$dd) = @$ymd;
push(@date,[$yy,$mm,$dd,0,0,0]);
}
}
}
}
}
} elsif ($n == 2) {
#
# Y:M*W:D:H:MN:S
#
if ($w_empty) {
# 0:2*0:0 every 2 months on the first day of the month
# 0:2*0:4 every 2 months on the 4th day of the month
# 1:2*0:0 every 1 year, 2 months on the first day of the month
# 1:2*0:4 every 1 year, 2 months on the 4th day of the month
$df = [1] if ($d_empty);
($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
return () if ($err);
foreach my $d (@d) {
push(@date,[$y,$m,$d,0,0,0]);
}
} else {
# 0:2*3:0 every 2 months on the 3rd occurrence of FirstDay
# 0:2*3:4 every 2 months on the 3rd Thur of the month
# 1:2*3:0 every 1 year, 2 months on 3rd occurrence of FirstDay
# 1:2*3:4 every 1 year, 2 months on the 3rd Thur of the month
if ($d_empty) {
@dow = ($dmb->_config('firstday'));
} else {
($err,@dow) = $self->_rtime_values('day_of_week',$df);
return () if ($err);
}
foreach my $dow (@dow) {
($err,@n) = $self->_rtime_values('dow_of_month',
$wf,$y,$m,$dow);
return () if ($err);
foreach my $n (@n) {
my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
my($yy,$mm,$dd) = @$ymd;
push(@date,[$yy,$mm,$dd,0,0,0]);
}
}
}
} elsif ($n == 3) {
#
# Y:M:W*D:H:MN:S
#
# 0:0:3*0 every 3 weeks on FirstDay
# 0:0:3*4 every 3 weeks on Thur
# 0:2:3*0 every 2 months, 3 weeks on FirstDay
# 0:2:3*4 every 2 months, 3 weeks on Thur
# 1:0:3*0 every 1 year, 3 weeks on FirstDay
# 1:0:3*4 every 1 year, 3 weeks on Thur
# 1:2:3*0 every 1 year, 2 months, 3 weeks on FirstDay
# 1:2:3*4 every 1 year, 2 months, 3 weeks on Thur
my $fdow = $dmb->_config('firstday');
if ($d_empty) {
@dow = ($fdow);
} else {
($err,@dow) = $self->_rtime_values('day_of_week',$df);
return () if ($err);
}
my($mm,$dd);
my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]);
($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) };
foreach my $dow (@dow) {
$dow += 7 if ($dow < $fdow);
my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) };
push(@date,[$yyy,$mmm,$ddd,0,0,0]);
}
} elsif ($n == 4) {
#
# Y:M:W:D*H:MN:S
#
push(@date,[$y,$m,$d,0,0,0]);
} elsif ($n == 5) {
#
# Y:M:W:D:H*MN:S
#
push(@date,[$y,$m,$d,$h,0,0]);
} elsif ($n == 6) {
#
# Y:M:W:D:H:MN*S
#
push(@date,[$y,$m,$d,$h,$mn,0]);
} elsif ($n == 7) {
#
# Y:M:W:D:H:MN:S
#
push(@date,[$y,$m,$d,$h,$mn,$s]);
}
#
# Handle the H/MN/S portion.
#
# Do hours
if ($n <= 4 ) {
($err,@h) = $self->_rtime_values('h',$hf);
return () if ($err);
$self->_field_add_values(\@date,3,@h);
}
# Do minutes
if ($n <= 5) {
($err,@mn) = $self->_rtime_values('mn',$mnf);
return () if ($err);
$self->_field_add_values(\@date,4,@mn);
}
# Do seconds
if ($n <= 6) {
($err,@s) = $self->_rtime_values('s',$sf);
return () if ($err);
$self->_field_add_values(\@date,5,@s);
}
# Sort the dates... just to be sure.
@date = sort { $dmb->cmp($a,$b) } @date if (@date);
#
# Apply modifiers
#
my @flags = @{ $$self{'data'}{'flags'} };
if (@flags) {
my $obj = $self->new_date();
my @keep;
foreach my $date (@date) {
my ($y,$m,$d,$h,$mn,$s) = @$date;
my $keep = 1;
MODIFIER:
foreach my $flag (@flags) {
my(@wd,$today);
if ($flag =~ /^([pn])([dt])([1-7])$/) {
my($forw,$today,$dow) = ($1,$2,$3);
$forw = ($forw eq 'p' ? 0 : 1);
$today = ($today eq 'd' ? 0 : 1);
($y,$m,$d,$h,$mn,$s) =
@{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) };
} elsif ($flag =~ /^([fb])([dw])(\d+)$/) {
my($prev,$business,$n) = ($1,$2,$3);
$prev = ($prev eq 'b' ? 1 : 0);
$business = ($business eq 'w' ? 1 : 0);
if ($business) {
($y,$m,$d,$h,$mn,$s) =
@{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) };
} else {
($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) };
}
} elsif ($flag eq 'ibd' ||
$flag eq 'nbd') {
my $bd = $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0);
if ( ($flag eq 'ibd' && ! $bd) ||
($flag eq 'nbd' && $bd) ) {
$keep = 0;
last MODIFIER;
}
} elsif ($flag =~ /^([in])w([1-7])$/) {
my($is,$dow) = ($1,$2);
$is = ($is eq 'i' ? 1 : 0);
my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
if ( ($is && $dow != $currdow) ||
(! $is && $dow == $currdow) ) {
$keep = 0;
last MODIFIER;
}
} elsif ($flag =~ /^wd([1-7])$/) {
my $dow = $1; # Dow wanted
my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
if ($dow != $currdow) {
my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]); # What week is this
my $tmp = $dmb->week_of_year($yy,$ww); # First day of week
($y,$m,$d) = @$tmp;
$currdow = $dmb->_config('firstday');
if ($dow > $currdow) {
$tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow);
($y,$m,$d) = @$tmp;
} elsif ($dow < $currdow) {
$tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow+7);
($y,$m,$d) = @$tmp;
}
}
} elsif ($flag eq 'nwd') {
if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
($y,$m,$d,$h,$mn,$s) =
@{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) };
}
} elsif ($flag eq 'pwd') {
if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
($y,$m,$d,$h,$mn,$s) =
@{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) };
}
} elsif ($flag eq 'easter') {
($m,$d) = $self->_easter($y);
} elsif ($flag eq 'dwd' &&
$obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
# nothing
} else {
if ($flag eq 'cwd' || $flag eq 'dwd') {
if ($dmb->_config('tomorrowfirst')) {
@wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
} else {
@wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
}
} elsif ($flag eq 'cwn') {
@wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
$today = 0;
} elsif ($flag eq 'cwp') {
@wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
$today = 0;
}
while (1) {
my(@d,$off);
# Test in the first direction
@d = @{ $wd[0] };
$off = $wd[1];
@d = @{ $dmb->calc_date_days(\@d,$off) };
if ($obj->__is_business_day(\@d,0)) {
($y,$m,$d,$h,$mn,$s) = @d;
last;
}
$wd[0] = [@d];
# Test in the other direction
@d = @{ $wd[2] };
$off = $wd[3];
@d = @{ $dmb->calc_date_days(\@d,$off) };
if ($obj->__is_business_day(\@d,0)) {
($y,$m,$d,$h,$mn,$s) = @d;
last;
}
$wd[2] = [@d];
}
}
}
if ($keep) {
push(@keep,[$y,$m,$d,$h,$mn,$s]);
}
}
@date = @keep;
}
#
# Convert the dates to objects.
#
my(@ret);
foreach my $date (@date) {
my @d = @$date;
my $obj = $self->new_date();
$obj->set('date',\@d);
if ($obj->err()) {
push(@ret,undef);
} else {
push(@ret,$obj);
}
}
return @ret;
}
# This calculates the Nth interval date (0 is the base date) and then
# calculates the recurring events produced by it.
#
sub _nth_interval {
my($self,$n) = @_;
return if (exists $$self{'data'}{'idate'}{$n});
my $base = $$self{'data'}{'BASE'};
my $date;
# Get the interval date.
if ($n == 0) {
$date = $base;
} else {
my @delta = $$self{'data'}{'delta'}->value;
my $absn = abs($n);
@delta = map { $absn*$_ } @delta;
my $delta = $self->new_delta;
$delta->set('delta',[@delta]);
$date = $base->calc($delta, ($n>0 ? 0 : 2));
}
# For 'slow' recursion, we need to make sure we've got
# the n-1 or n+1 interval as appropriate.
if ($$self{'data'}{'slow'}) {
if ($n > 0) {
$self->_nth_interval($n-1);
} elsif ($n < 0) {
$self->_nth_interval($n+1);
}
}
# Get the list of events associated with this interval date.
my @date = $self->_apply_rtime_mods($date);
# Determine the index of the earliest event associated with
# this interval date.
#
# Events are numbered [$n0...$n1]
my($n0,$n1);
if ($$self{'data'}{'slow'}) {
if (! @date) {
$n0 = undef;
$n1 = undef;
} elsif ($n == 0) {
$n0 = 0;
$n1 = $#date;
} elsif ($n > 0) {
foreach (my $i = $n-1; $i >= 0; $i--) {
next if (! defined $$self{'data'}{'idate'}{$i}[2]);
$n0 = $$self{'data'}{'idate'}{$i}[2] + 1;
last;
}
$n0 = 0 if (! defined $n0);
$n1 = $n0 + $#date;
} else {
foreach (my $i = $n+1; $i <= 0; $i++) {
next if (! defined $$self{'data'}{'idate'}{$i}[1]);
$n1 = $$self{'data'}{'idate'}{$i}[1] - 1;
last;
}
$n1 = -1 if (! defined $n1);
$n0 = $n1 - $#date;
}
} else {
# ev_per_d = 3
# idate = 0 1 2
# events = 0 1 2 3 4 5 6 7 8
# ev_per_d = 3
# idate = -1 -2 -3
# events = -3 -2 -1 -6 -5 -4 -9 -8 -7
$n0 = $n * $$self{'data'}{'ev_per_d'};
$n1 = $n0 + $$self{'data'}{'ev_per_d'} - 1;
}
# Store the dates.
for (my $i=0; $i<=$#date; $i++) {
$$self{'data'}{'dates'}{$n0+$i} = $date[$i];
}
# Store the idate.
if ($$self{'data'}{'slow'}) {
$$self{'data'}{'idate'}{$n} = [$date,$n0,$n1];
} else {
$$self{'data'}{'idate'}{$n} = $date;
}
}
# This locates the first/last event in the range and returns $n. It
# returns undef if there is no date in the range.
#
sub _locate_n {
my($self,$op) = @_;
return $$self{'data'}{$op} if (defined $$self{'data'}{$op});
my $start = $$self{'data'}{'start'};
my $end = $$self{'data'}{'end'};
my $unmod = $$self{'data'}{'unmod_range'};
if ($$self{'data'}{'noint'} == 2) {
# If there is no interval, then we have calculated all the dates
# possible. Work with them only.
my($i,$first,$last);
# Find the first date in the interval
$i = 0;
while (1) {
last if (! exists $$self{'data'}{'dates'}{$i});
my $date = $$self{'data'}{'dates'}{$i};
if ($date->cmp($start) == -1) {
# date < start : move to the next one
$i++;
next;
} elsif ($date->cmp($end) == 1) {
# date > end : we're done
last;
} else {
# start <= date <= end : this is the first one
$first = $i;
last;
}
}
# If we found one, find the last one
if (defined($first)) {
$i = $first;
$last = $i;
while (1) {
last if (! exists $$self{'data'}{'dates'}{$i});
my $date = $$self{'data'}{'dates'}{$i};
if ($date->cmp($end) == 1) {
# date > end : we're done
last;
} else {
# date <= end : this might be the last one
$last = $i;
$i++;
next;
}
}
}
$$self{'data'}{'first'} = $first;
$$self{'data'}{'last'} = $last;
return $$self{'data'}{$op}
}
# Given interval date Idate(n) produces event dates: Date(f)..Date(l)
#
# If we're looking at unmodified dates:
# Find smallest n such that:
# Idate(n) >= start
# first=f
# Then find largest n such that:
# Idate(n) <= end
# last=l
# Otherwise
# Find smallest n such that
# Date(y) >= start
# first=z (smallest z)
# Where x <= z <= y and
# Date(z) >= start
# Then find largest n such that
# Date(x) <= end
# last=z (largest z)
# Where x <= z <= y and
# Date(z) <= end
my($first_int,$last_int,$first,$last);
if ($$self{'data'}{'slow'}) {
#
# For a 'slow' recurrence, we have to start at 0 and work forwards
# or backwards.
#
# Move backwards until we're completely before start
$first_int = 0;
if ($unmod) {
while (1) {
$self->_nth_interval($first_int);
my $date = $$self{'data'}{'idate'}{$first_int}[0];
last if (defined $date && $date->cmp($start) < 0);
$first_int--;
}
} else {
while (1) {
$self->_nth_interval($first_int);
my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
if (defined $ptr) {
my $date = $$self{'data'}{'dates'}{$ptr};
last if (defined $date && $date->cmp($start) < 0);
}
$first_int--;
}
}
# Then move forwards until we're after start
# i.e. Date(y) >= start for modified dates
if ($unmod) {
while (1) {
$self->_nth_interval($first_int);
my $date = $$self{'data'}{'idate'}{$first_int}[0];
last if (defined $date && $date->cmp($start) >= 0);
$first_int++;
}
$first = $$self{'data'}{'idate'}{$first_int}[1];
} else {
while (1) {
$self->_nth_interval($first_int);
my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
if (defined $ptr) {
my $date = $$self{'data'}{'dates'}{$ptr};
last if (defined $date && $date->cmp($start) >= 0);
}
$first_int++;
}
foreach my $i ($$self{'data'}{'idate'}{$first_int}[1] ..
$$self{'data'}{'idate'}{$first_int}[2]) {
my $date = $$self{'data'}{'dates'}{$i};
if (defined $date && $date->cmp($start) >= 0) {
$first = $i;
last;
}
}
}
# Then move forwards until we're after end
# i.e. Date(x) > end for modified dates
$last_int = $first_int;
if ($unmod) {
while (1) {
$self->_nth_interval($last_int);
my $date = $$self{'data'}{'idate'}{$last_int}[0];
last if (defined $date && $date->cmp($end) > 0);
$last_int++;
}
$last_int--;
for (my $i=$$self{'data'}{'idate'}{$last_int}[2];
$i >= $$self{'data'}{'idate'}{$last_int}[1]; $i--) {
my $date = $$self{'data'}{'dates'}{$i};
if (defined $date) {
$last = $i;
last;
}
}
} else {
while (1) {
$self->_nth_interval($last_int);
my $ptr = $$self{'data'}{'idate'}{$last_int}[1];
if (defined $ptr) {
my $date = $$self{'data'}{'dates'}{$ptr};
last if (defined $date && $date->cmp($end) > 0);
}
$last_int++;
}
$last_int--;
$last = undef;
my $i = $first;
while (1) {
last if (! exists $$self{'data'}{'dates'}{$i});
my $date = $$self{'data'}{'dates'}{$i};
next if (! defined $date);
last if ($date->cmp($end) > 0);
$last = $i;
$i++;
}
}
return undef if (! defined $last ||
$last < $first);
$$self{'data'}{'first'} = $first;
$$self{'data'}{'last'} = $last;
return $$self{'data'}{$op}
}
#
# For a normal recurrence, we can estimate which interval date we're
# interested in and then move forward/backward from it.
#
# Calculate the interval date index ($nn) based on the length of
# the delta.
#
# For the Nth interval, the dates produced are:
# N*EV_PER_DAY to (N+1)EV_PER_DAY-1
#
my $base = $$self{'data'}{'BASE'};
my $delta = $$self{'data'}{'delta'};
# $len = 0 is when a recur contains no delta (i.e. *Y:M:W:D:H:Mn:S)
my $len = ($delta ? $delta->printf('%sys') : 0);
my $targ = ($op eq 'first' ? $start : $end);
my $diff = $base->calc($targ);
my $tot = $diff->printf('%sys');
my $nn = ($len ? int($tot/$len) : 1);
my $ev = $$self{'data'}{'ev_per_d'};
# Move backwards until we're completely before start
$first_int = $nn;
if ($unmod) {
while (1) {
$self->_nth_interval($first_int);
my $date = $$self{'data'}{'idate'}{$first_int};
last if (defined $date && $date->cmp($start) < 0);
$first_int--;
}
} else {
LOOP:
while (1) {
$self->_nth_interval($first_int);
for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
next if (! exists $$self{'data'}{'dates'}{$i});
my $date = $$self{'data'}{'dates'}{$i};
last LOOP if ($date->cmp($start) < 0);
}
$first_int--;
}
}
# Then move forwards until we're after start
# i.e. Date(y) >= start for modified dates
if ($unmod) {
while (1) {
$self->_nth_interval($first_int);
my $date = $$self{'data'}{'idate'}{$first_int};
last if (defined $date && $date->cmp($start) >= 0);
$first_int++;
}
} else {
LOOP:
while (1) {
$self->_nth_interval($first_int);
for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
next if (! exists $$self{'data'}{'dates'}{$i});
my $date = $$self{'data'}{'dates'}{$i};
last LOOP if ($date->cmp($start) >= 0);
}
$first_int++;
}
}
$first = $first_int*$ev;
# Then move forwards until we're after end
# i.e. Date(y) > end for modified dates
$last_int = $first_int;
if ($unmod) {
while (1) {
$self->_nth_interval($last_int);
my $date = $$self{'data'}{'idate'}{$last_int};
last if (defined $date && $date->cmp($end) > 0);
$last_int++;
}
$last_int--;
} else {
LOOP:
while (1) {
$self->_nth_interval($last_int);
for (my $i=($last_int+1)*$ev - 1; $i >= $last_int*$ev; $i--) {
next if (! exists $$self{'data'}{'dates'}{$i});
my $date = $$self{'data'}{'dates'}{$i};
last LOOP if ($date->cmp($end) >= 0);
}
$last_int++;
}
}
$last = ($last_int+1)*$ev - 1;
# Now get the actual first/last dates
if ($unmod) {
while (1) {
last if (exists $$self{'data'}{'dates'}{$first} &&
defined $$self{'data'}{'dates'}{$first});
$first++;
return undef if ($first > $last);
}
while (1) {
last if (exists $$self{'data'}{'dates'}{$last} &&
defined $$self{'data'}{'dates'}{$last});
$last--;
}
} else {
while (1) {
last if (exists $$self{'data'}{'dates'}{$first} &&
defined $$self{'data'}{'dates'}{$first} &&
$$self{'data'}{'dates'}{$first}->cmp($start) >= 0);
$first++;
return undef if ($first > $last);
}
while (1) {
last if (exists $$self{'data'}{'dates'}{$last} &&
defined $$self{'data'}{'dates'}{$last} &&
$$self{'data'}{'dates'}{$last}->cmp($end) <= 0);
$last--;
}
}
return undef if (! defined $last ||
$last < $first);
$$self{'data'}{'first'} = $first;
$$self{'data'}{'last'} = $last;
return $$self{'data'}{$op}
}
# This returns the date easter occurs on for a given year as ($month,$day).
# This is from the Calendar FAQ.
#
sub _easter {
my($self,$y) = @_;
my($c) = $y/100;
my($g) = $y % 19;
my($k) = ($c-17)/25;
my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30;
$i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11));
my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
my($l) = $i-$j;
my($m) = 3 + ($l+40)/44;
my($d) = $l + 28 - 31*($m/4);
return ($m,$d);
}
# This returns 1 if a field is empty.
#
sub _field_empty {
my($self,$val) = @_;
if (ref($val)) {
my @tmp = @$val;
return 1 if ($#tmp == -1 ||
($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0]));
return 0;
} else {
return $val;
}
}
# This returns a list of values that appear in a field in the rtime.
#
# $val is a listref, with each element being a value or a range.
#
# Usage:
# _rtime_values('y' ,$y);
# _rtime_values('m' ,$m);
# _rtime_values('week_of_year' ,$w ,$y);
# _rtime_values('dow_of_year' ,$w ,$y,$dow);
# _rtime_values('dow_of_month' ,$w ,$y,$m,$dow);
# _rtime_values('day_of_year' ,$d ,$y);
# _rtime_values('day_of_month' ,$d ,$y,$m);
# _rtime_values('day_of_week' ,$d);
# _rtime_values('h' ,$h);
# _rtime_values('mn' ,$mn);
# _rtime_values('s' ,$s);
#
# Returns ($err,@vals)
#
sub _rtime_values {
my($self,$type,$val,@args) = @_;
my $dmt = $$self{'tz'};
my $dmb = $$dmt{'base'};
if ($type eq 'h') {
@args = (0,0,23,23);
} elsif ($type eq 'mn') {
@args = (0,0,59,59);
} elsif ($type eq 's') {
@args = (0,0,59,59);
} elsif ($type eq 'y') {
my $curry = $dmt->_now('y',1);
foreach my $y (@$val) {
$y = $curry if (! ref($y) && $y==0);
}
@args = (0,1,9999,9999);
} elsif ($type eq 'm') {
@args = (0,1,12,12);
} elsif ($type eq 'week_of_year') {
my($y) = @args;
my $wiy = $dmb->weeks_in_year($y);
@args = (1,1,$wiy,53);
} elsif ($type eq 'dow_of_year') {
my($y,$dow) = @args;
# Get the 1st occurrence of $dow
my $d0 = 1;
my $dow0 = $dmb->day_of_week([$y,1,$d0]);
if ($dow > $dow0) {
$d0 += ($dow-$dow0);
} elsif ($dow < $dow0) {
$d0 += 7-($dow0-$dow);
}
# Get the last occurrence of $dow
my $d1 = 31;
my $dow1 = $dmb->day_of_week([$y,12,$d1]);
if ($dow1 > $dow) {
$d1 -= ($dow1-$dow);
} elsif ($dow1 < $dow) {
$d1 -= 7-($dow-$dow1);
}
# Find out the number of occurrenced of $dow
my $doy1 = $dmb->day_of_year([$y,12,$d1]);
my $n = ($doy1 - $d0)/7 + 1;
# Get the list of @w
@args = (1,1,$n,53);
} elsif ($type eq 'dow_of_month') {
my($y,$m,$dow) = @args;
# Get the 1st occurrence of $dow in the month
my $d0 = 1;
my $dow0 = $dmb->day_of_week([$y,$m,$d0]);
if ($dow > $dow0) {
$d0 += ($dow-$dow0);
} elsif ($dow < $dow0) {
$d0 += 7-($dow0-$dow);
}
# Get the last occurrence of $dow
my $d1 = $dmb->days_in_month($y,$m);
my $dow1 = $dmb->day_of_week([$y,$m,$d1]);
if ($dow1 > $dow) {
$d1 -= ($dow1-$dow);
} elsif ($dow1 < $dow) {
$d1 -= 7-($dow-$dow1);
}
# Find out the number of occurrenced of $dow
my $n = ($d1 - $d0)/7 + 1;
# Get the list of @w
@args = (1,1,$n,5);
} elsif ($type eq 'day_of_year') {
my($y) = @args;
my $diy = $dmb->days_in_year($y);
@args = (1,1,$diy,366);
} elsif ($type eq 'day_of_month') {
my($y,$m) = @args;
my $dim = $dmb->days_in_month($y,$m);
@args = (1,1,$dim,31);
} elsif ($type eq 'day_of_week') {
@args = (0,1,7,7);
}
my($err,@vals) = $self->__rtime_values($val,@args);
if ($err) {
$$self{'err'} = "[dates] $err [$type]";
return (1);
}
return(0,@vals);
}
# This returns the raw values for a list.
#
# If $allowneg is 0, only positive numbers are allowed, and they must be
# in the range [$min,$absmax]. If $allowneg is 1, positive numbers in the
# range [$min,$absmax] and negative numbers in the range [-$absmax,-$min]
# are allowed. An error occurs if a value falls outside the range.
#
# Only values in the range of [$min,$max] are actually kept. This allows
# a recurrence for day_of_month to be 1-31 and not fail for a month that
# has fewer than 31 days. Any value outside the [$min,$max] are silently
# discarded.
#
# Returns:
# ($err,@vals)
#
sub __rtime_values {
my($self,$vals,$allowneg,$min,$max,$absmax) = @_;
my(@ret);
foreach my $val (@$vals) {
if (ref($val)) {
my($val1,$val2) = @$val;
if ($allowneg) {
return ('Value outside range')
if ( ($val1 >= 0 && ($val1 < $min || $val1 > $absmax) ) ||
($val2 >= 0 && ($val2 < $min || $val2 > $absmax) ) );
return ('Negative value outside range')
if ( ($val1 <= 0 && ($val1 < -$absmax || $val1 > -$min) ) ||
($val2 <= 0 && ($val2 < -$absmax || $val2 > -$min) ) );
} else {
return ('Value outside range')
if ( ($val1 < $min || $val1 > $absmax) ||
($val2 < $min || $val2 > $absmax) );
}
return ('Range values reversed')
if ( ($val1 <= 0 && $val2 <= 0 && $val1 > $val2) ||
($val1 >= 0 && $val2 >= 0 && $val1 > $val2) );
# Use $max instead of $absmax when converting negative numbers to
# positive ones.
$val1 = $max + $val1 + 1 if ($val1 < 0); # day -10
$val2 = $max + $val2 + 1 if ($val2 < 0);
$val1 = $min if ($val1 < $min); # day -31 in a 30 day month
$val2 = $max if ($val2 > $max);
next if ($val1 > $val2);
push(@ret,$val1..$val2);
} else {
if ($allowneg) {
return ('Value outside range')
if ($val >= 0 && ($val < $min || $val > $absmax));
return ('Negative value outside range')
if ($val <= 0 && ($val < -$absmax || $val > -$min));
} else {
return ('Value outside range')
if ($val < $min || $val > $absmax);
}
# Use $max instead of $absmax when converting negative numbers to
# positive ones.
my $ret;
if ($val < 0 ) {
$ret = $max + $val + 1;
} else {
$ret = $val;
}
next if ($ret > $max || $ret < $min);
push(@ret,$ret);
}
}
return ('',@ret);
}
# This takes a list of dates (each a listref of [y,m,d,h,mn,s]) and replaces
# the Nth field with all of the possible values passed in, creating a new
# list with all the dates.
#
sub _field_add_values {
my($self,$datesref,$n,@val) = @_;
my @dates = @$datesref;
my @tmp;
foreach my $date (@dates) {
my @d = @$date;
foreach my $val (@val) {
$d[$n] = $val;
push(@tmp,[@d]);
}
}
@$datesref = @tmp;
}
1;
# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 3
# cperl-continued-statement-offset: 2
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
# cperl-label-offset: 0
# End: