###############################################################################
## Copyright (c) 2000 - 2002 by Steffen Beyer. ##
## All rights reserved. ##
## This package is free software; you can redistribute it ##
## and/or modify it under the same terms as Perl itself. ##
###############################################################################
package Date
::Calendar
::Year
;
use vars
qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION );
@EXPORT_OK = qw( check_year empty_period );
%EXPORT_TAGS = (all
=> [@EXPORT_OK]);
use Carp
::Clan
qw(^Date::);
use Date
::Calc
::Object
qw(:ALL);
my($year) = shift_year
(\
@_);
if (($year < 1583) || ($year > 2299))
croak
("given year ($year) out of range [1583..2299]");
carp
("dates interval is empty") if ($^W
);
croak
("date '$item' for day '$name' is invalid");
my($item,$name,$year,$yy,$mm,$dd) = @_;
unless (($year == $yy) && (check_date
($yy,$mm,$dd)));
sub _check_callback_date_
my($name,$year,$yy,$mm,$dd) = @_;
croak
("callback function for day '$name' returned invalid date")
unless (($year == $yy) && (check_date
($yy,$mm,$dd)));
my($self,$name,$yy,$mm,$dd,$flag) = @_;
$index = $self->date2index($yy,$mm,$dd);
if ($flag eq ':') { ${$self}{'HALF'}->Bit_On( $index ); }
else { ${$self}{'FULL'}->Bit_On( $index ); }
$self->{'TAGS'}{$index}{$name} = 1;
if ($_[1] =~ /^[a-zA-Z]+$/)
&_invalid_
($item,$name) unless ($_[1] = Decode_Month
($_[1]));
&_check_init_date_
($item,$name,$year,@_);
&_set_date_
($self,$name,@_);
my($yy,$mm,$dd) = shift_date
(\
@_);
$year = ${$self}{'YEAR'};
croak
("given year ($yy) != object's year ($year)");
if ((check_date
($yy,$mm,$dd)) &&
(($index = (Date_to_Days
($yy,$mm,$dd) - ${$self}{'BASE'})) >= 0) &&
($index < ${$self}{'DAYS'}))
else { croak
("invalid date ($yy,$mm,$dd)"); }
$year = ${$self}{'YEAR'};
($index < ${$self}{'DAYS'}) &&
(($yy,$mm,$dd) = Add_Delta_Days
($year,1,1, $index)) &&
return Date
::Calc
->new($yy,$mm,$dd);
else { croak
("invalid index ($index)"); }
my($year) = shift_year
(\
@_);
my($language) = shift || 0;
$class = ref($class) || $class || 'Date::Calendar::Year';
$self->init($year,$profile,$language);
my($year) = shift_year
(\
@_);
my($language) = shift || 0;
my($days,$dow,$lang,$name,$item,$flag,$temp,$n);
croak
("given profile is not a HASH ref") unless (ref($profile) eq 'HASH');
$days = Days_in_Year
($year,12);
${$self}{'YEAR'} = $year;
${$self}{'DAYS'} = $days;
${$self}{'BASE'} = Date_to_Days
($year,1,1);
${$self}{'HALF'} = Bit
::Vector
->new($days);
${$self}{'FULL'} = Bit
::Vector
->new($days);
${$self}{'WORK'} = Bit
::Vector
->new($days);
$dow = Day_of_Week
($year,1,1);
$dow = 7 - $dow if ($dow != 7);
${$self}{'FULL'}->Bit_On( $dow ); # Saturday
${$self}{'FULL'}->Bit_On( $dow ) if (++$dow < $days); # Sunday
@easter = Easter_Sunday
($year);
if ($language =~ /^\d+$/)
if (($language > 0) and ($language <= Languages
()))
{ $lang = Language
($language); }
if ($language = Decode_Language
($language))
{ $lang = Language
($language); }
foreach $name (keys %{$profile})
$item = ${$profile}{$name};
if (ref($item) eq 'CODE')
if (@date = &$item($year,$name))
&_check_callback_date_
($name,$year,@date);
&_set_date_
($self,$name,@date);
else { croak
("value for day '$name' is not a CODE ref"); }
elsif ($item =~ /^ ([#:]?) ([+-]\d+) $/x)
if ($temp == 0) { @date = @easter; }
else { @date = Add_Delta_Days
(@easter, $temp); }
&_check_init_date_
($item,$name,$year,@date);
&_set_date_
($self,$name,@date,$flag);
elsif (($item =~ /^ ([#:]?) (\d+) \. (\d+) \.? $/x) ||
($item =~ /^ ([#:]?) (\d+) \.? ([a-zA-Z]+) \.? $/x) ||
($item =~ /^ ([#:]?) (\d+) - (\d+|[a-zA-Z]+) -? $/x))
&_set_fixed_date_
($self,$item,$name,$year,@date,$flag);
elsif (($item =~ /^ ([#:]?) (\d+) \/ (\d
+) $/x
) ||
($item =~ /^ ([#:]?) ([a-zA-Z]+) \/?
(\d
+) $/x
))
&_set_fixed_date_
($self,$item,$name,$year,@date,$flag);
elsif (($item =~ /^ ([#:]?) ([1-5]) ([a-zA-Z]+) (\d+) $/x) ||
($item =~ /^ ([#:]?) ([1-5]) \/ ([1-7]|[a
-zA
-Z
]+) \
/ (\d+|[a-zA-Z]+) $/x))
if ($dow =~ /^[a-zA-Z]+$/)
&_invalid_
($item,$name) unless ($dow = Decode_Day_of_Week
($dow));
if ($temp =~ /^[a-zA-Z]+$/)
&_invalid_
($item,$name) unless ($temp = Decode_Month
($temp));
&_invalid_
($item,$name) unless (($temp > 0) && ($temp < 13));
unless (@date = Nth_Weekday_of_Month_Year
($year,$temp,$dow,$n))
unless (@date = Nth_Weekday_of_Month_Year
($year,$temp,$dow,4));
else { &_invalid_
($item,$name); }
&_set_date_
($self,$name,@date,$flag);
croak
("unrecognized date '$item' for day '$name'");
${$self}{'HALF'}->AndNot( ${$self}{'HALF'}, ${$self}{'FULL'} );
sub vec_full
# full holidays
sub vec_half
# half holidays
sub vec_work
# work space
sub year
# as a shortcut and to enable shift_year
$index = $self->date2index(@date);
if (defined $self->{'TAGS'}{$index})
if (defined wantarray and wantarray)
Day_of_Week_to_Text
(Day_of_Week
(@date)),
keys(%{$self->{'TAGS'}{$index}})
return 1 + scalar( keys(%{$self->{'TAGS'}{$index}}) );
if (defined wantarray and wantarray)
return( Day_of_Week_to_Text
(Day_of_Week
(@date)) );
foreach $index (keys %{$self->{'TAGS'}})
grep( $result{$_} = 0, keys(%{$self->{'TAGS'}{$index}}) );
if (defined wantarray and wantarray)
return scalar( keys %result );
my($index,$label,$upper);
$pattern = ISO_UC
($pattern);
foreach $index (keys %{$self->{'TAGS'}})
foreach $label (keys %{$self->{'TAGS'}{$index}})
if (index($upper,$pattern) >= $[)
return( map( $self->index2date($_), sort {$a<=>$b} @result ) );
my($self,$lower,$upper) = @_;
my($work,$full,$half,$days);
$work = ${$self}{'WORK'};
$full = ${$self}{'FULL'};
$half = ${$self}{'HALF'};
$work->Interval_Fill($lower,$upper);
$work->AndNot($work,$full);
$days -= $work->Norm() * 0.5;
my($self,$lower_index,$upper_index,$include_lower,$include_upper) = @_;
$days = ${$self}{'DAYS'};
if (($lower_index < 0) || ($lower_index >= $days))
croak
("invalid lower index ($lower_index)");
if (($upper_index < 0) || ($upper_index >= $days))
croak
("invalid upper index ($upper_index)");
if ($lower_index > $upper_index)
croak
("lower index ($lower_index) > upper index ($upper_index)");
$lower_index++ unless ($include_lower);
$upper_index-- unless ($include_upper);
if (($upper_index < 0) ||
($lower_index >= $days) ||
($lower_index > $upper_index))
return $self->_interval_workdays_($lower_index,$upper_index);
my($yy1,$mm1,$dd1) = shift_date
(\
@_);
my($yy2,$mm2,$dd2) = shift_date
(\
@_);
my($including1,$including2) = (shift,shift);
$index1 = $self->date2index($yy1,$mm1,$dd1);
$index2 = $self->date2index($yy2,$mm2,$dd2);
return -$self->_delta_workdays_(
$index2,$index1,$including2,$including1);
return $self->_delta_workdays_(
$index1,$index2,$including1,$including2);
my($self,$index,$rest,$sign) = @_;
my($limit,$year,$full,$half,$loop,$min,$max);
return( $self->index2date($index), $rest, 0 );
$limit = ${$self}{'DAYS'} - 1;
$year = ${$self}{'YEAR'};
$full = ${$self}{'FULL'};
$half = ${$self}{'HALF'};
$rest = -$rest if ($rest < 0);
if ($full->bit_test($index) &&
(($min,$max) = $full->Interval_Scan_inc($index)) &&
return( Date
::Calc
->new(++$year,1,1), $rest, +1 );
else { $index = $max + 1; }
if ($half->bit_test($index))
if ($rest >= 0.5) { $rest -= 0.5; $index++; $loop = 1; }
elsif ($rest >= 1.0) { $rest -= 1.0; $index++; $loop = 1; }
if ($loop && ($index > $limit))
return( Date
::Calc
->new(++$year,1,1), $rest, +1 );
return( $self->index2date($index), $rest, 0 );
$rest = -$rest if ($rest > 0);
if ($full->bit_test($index) &&
(($min,$max) = $full->Interval_Scan_dec($index)) &&
return( Date
::Calc
->new(--$year,12,31), $rest, -1 );
else { $index = $min - 1; }
if ($half->bit_test($index))
if ($rest <= -0.5) { $rest += 0.5; $index--; $loop = 1; }
elsif ($rest <= -1.0) { $rest += 1.0; $index--; $loop = 1; }
if ($loop && ($index < 0))
return( Date
::Calc
->new(--$year,12,31), $rest, -1 );
return( $self->index2date($index), $rest, 0 );
my($yy,$mm,$dd) = shift_date
(\
@_);
my($index,$full,$half,$limit,$diff,$guess);
$index = $self->date2index($yy,$mm,$dd); # check date
return( Date
::Calc
->new($yy,$mm,$dd), $days, 0 );
$days = -$days if ($days < 0);
if ($days < 2) # other values possible for fine-tuning optimal speed
return( $self->_move_forward_($index,$days,$sign) );
# else sufficiently large distance
$full = ${$self}{'FULL'};
$half = ${$self}{'HALF'};
# First, check against whole rest of year:
$limit = ${$self}{'DAYS'} - 1;
$diff = $self->_interval_workdays_($index,$limit);
return( Date
::Calc
->new(++$yy,1,1), $days, +1 );
# Now calculate proportional jump (approximatively):
$guess = $index + int($days * ($limit-$index+1) / $diff);
$guess = $limit if ($guess > $limit);
if ($index + 2 > $guess) # again, other values possible for fine-tuning
return( $self->_move_forward_($index,$days,+1) );
# else sufficiently long jump
$diff = $self->_interval_workdays_($index,$guess-1);
while ($days < $diff) # reverse gear (jumped too far)
unless ($full->bit_test($guess))
if ($half->bit_test($guess)) { $diff -= 0.5; }
# Now move in original direction:
return( $self->_move_forward_($guess,$days,+1) );
# First, check against whole rest of year:
$diff = $self->_interval_workdays_($limit,$index);
return( Date
::Calc
->new(--$yy,12,31), -$days, -1 );
# Now calculate proportional jump (approximatively):
$guess = $index - int($days * ($index+1) / $diff);
$guess = $limit if ($guess < $limit);
if ($guess > $index - 2) # again, other values possible for fine-tuning
return( $self->_move_forward_($index,-$days,-1) );
# else sufficiently long jump
$diff = $self->_interval_workdays_($guess+1,$index);
while ($days < $diff) # reverse gear (jumped too far)
unless ($full->bit_test($guess))
if ($half->bit_test($guess)) { $diff -= 0.5; }
# Now move in original direction:
return( $self->_move_forward_($guess,-$days,-1) );
my(@date) = shift_date
(\
@_);
return $self->vec_full->bit_test( $self->date2index(@date) );
my(@date) = shift_date
(\
@_);
return $self->vec_half->bit_test( $self->date2index(@date) );
my(@date) = shift_date
(\
@_);
return $self->vec_work->bit_test( $self->date2index(@date) );