1 2############################################################################### 3## ## 4## Copyright (c) 2000 - 2015 by Steffen Beyer. ## 5## All rights reserved. ## 6## ## 7## This package is free software; you can redistribute it ## 8## and/or modify it under the same terms as Perl itself. ## 9## ## 10############################################################################### 11 12package Date::Calendar::Year; 13 14BEGIN { eval { require bytes; }; } 15use strict; 16use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION ); 17 18require Exporter; 19 20@ISA = qw(Exporter); 21 22@EXPORT = qw(); 23 24@EXPORT_OK = qw( check_year empty_period ); 25 26%EXPORT_TAGS = (all => [@EXPORT_OK]); 27 28$VERSION = '6.4'; 29 30use Bit::Vector; 31use Carp::Clan qw(^Date::); 32use Date::Calc::Object qw(:ALL); 33 34sub check_year 35{ 36 my($year) = shift_year(\@_); 37 38 if (($year < 1583) || ($year > 2299)) 39 { 40 croak("given year ($year) out of range [1583..2299]"); 41 } 42} 43 44sub empty_period 45{ 46 carp("dates interval is empty") if ($^W); 47} 48 49sub _invalid_ 50{ 51 my($item,$name) = @_; 52 53 croak("date '$item' for day '$name' is invalid"); 54} 55 56sub _check_init_date_ 57{ 58 my($item,$name,$year,$yy,$mm,$dd) = @_; 59 60 &_invalid_($item,$name) 61 unless (($year == $yy) && (check_date($yy,$mm,$dd))); 62} 63 64sub _check_callback_date_ 65{ 66 my($name,$year,$yy,$mm,$dd) = @_; 67 68 croak("callback function for day '$name' returned invalid date") 69 unless (($year == $yy) && (check_date($yy,$mm,$dd))); 70} 71 72sub _set_date_ 73{ 74 my($self,$name,$yy,$mm,$dd,$flag) = @_; 75 my($type,$index); 76 77 $type = 0; 78 $flag ||= ''; 79 $index = $self->date2index($yy,$mm,$dd); 80 if ($flag ne '#') 81 { 82 if ($flag eq ':') { ${$self}{'HALF'}->Bit_On( $index ); $type = 1; } 83 else { ${$self}{'FULL'}->Bit_On( $index ); $type = 2; } 84 } 85 $self->{'TAGS'}{$index}{$name} |= $type; 86} 87 88sub _set_fixed_date_ 89{ 90 my($self) = shift; 91 my($item) = shift; 92 my($name) = shift; 93 my($year) = shift; 94 my($lang) = shift || 0; 95 96 if ($_[1] =~ /^[a-zA-Z]+$/) 97 { 98 &_invalid_($item,$name) unless ($_[1] = Decode_Month($_[1]),$lang); 99 } 100 &_check_init_date_($item,$name,$year,@_); 101 &_set_date_($self,$name,@_); 102} 103 104sub date2index 105{ 106 my($self) = shift; 107 my($yy,$mm,$dd) = shift_date(\@_); 108 my($year,$index); 109 110 $year = ${$self}{'YEAR'}; 111 if ($yy != $year) 112 { 113 croak("given year ($yy) != object's year ($year)"); 114 } 115 if ((check_date($yy,$mm,$dd)) && 116 (($index = (Date_to_Days($yy,$mm,$dd) - ${$self}{'BASE'})) >= 0) && 117 ($index < ${$self}{'DAYS'})) 118 { 119 return $index; 120 } 121 else { croak("invalid date ($yy,$mm,$dd)"); } 122} 123 124sub index2date 125{ 126 my($self,$index) = @_; 127 my($year,$yy,$mm,$dd); 128 129 $year = ${$self}{'YEAR'}; 130 $yy = $year; 131 $mm = 1; 132 $dd = 1; 133 if (($index == 0) || 134 (($index > 0) && 135 ($index < ${$self}{'DAYS'}) && 136 (($yy,$mm,$dd) = Add_Delta_Days($year,1,1, $index)) && 137 ($yy == $year))) 138 { 139 return Date::Calc->new($yy,$mm,$dd); 140 } 141 else { croak("invalid index ($index)"); } 142} 143 144sub new 145{ 146 my($class) = shift; 147 my($year) = shift_year(\@_); 148 my($profile) = shift; 149 my($lang) = shift || 0; 150 my($self); 151 152 &check_year($year); 153 $self = { }; 154 $class = ref($class) || $class || 'Date::Calendar::Year'; 155 bless($self, $class); 156 $self->init($year,$profile,$lang,@_); 157 return $self; 158} 159 160sub init 161{ 162 my($self) = shift; 163 my($year) = shift_year(\@_); 164 my($profile) = shift; 165 my($lang) = shift || 0; 166 my($days,$dow,$name,$item,$flag,$temp,$n); 167 my(@weekend,@easter,@date); 168 169 if (@_ > 0) { @weekend = @_; } 170 else { @weekend = (6,7); } # Mon=1 Tue=2 Wed=3 Thu=4 Fri=5 Sat=6 Sun=7 171 &check_year($year); 172 croak("given profile is not a HASH ref") unless (ref($profile) eq 'HASH'); 173 $days = Days_in_Year($year,12); 174 ${$self}{'YEAR'} = $year; 175 ${$self}{'DAYS'} = $days; 176 ${$self}{'BASE'} = Date_to_Days($year,1,1); 177 ${$self}{'TAGS'} = { }; 178 ${$self}{'HALF'} = Bit::Vector->new($days); 179 ${$self}{'FULL'} = Bit::Vector->new($days); 180 ${$self}{'WORK'} = Bit::Vector->new($days); 181 $dow = Day_of_Week($year,1,1); # Mon=1 Tue=2 Wed=3 Thu=4 Fri=5 Sat=6 Sun=7 182 foreach $item (@weekend) 183 { 184 $n = $item || 0; 185 if (($n >= 1) and ($n <= 7)) 186 { 187 $n -= $dow; 188 while ($n < 0) { $n += 7; } 189 while ($n < $days) { ${$self}{'FULL'}->Bit_On( $n ); $n += 7; } 190 } 191 } 192 @easter = Easter_Sunday($year); 193 $lang = Decode_Language($lang) unless ($lang =~ /^\d+$/); 194 $lang = Language() unless (($lang >= 1) and ($lang <= Languages())); 195 foreach $name (keys %{$profile}) 196 { 197 @date = (); 198 $item = ${$profile}{$name}; 199 if (ref($item)) 200 { 201 if (ref($item) eq 'CODE') 202 { 203 if (@date = &$item($year,$name)) 204 { 205 &_check_callback_date_($name,$year,@date); 206 &_set_date_($self,$name,@date); 207 } 208 } 209 else { croak("value for day '$name' is not a CODE ref"); } 210 } 211 elsif ($item =~ /^ ([#:]?) ([+-]\d+) $/x) 212 { 213 $flag = $1; 214 $temp = $2; 215 if ($temp == 0) { @date = @easter; } 216 else { @date = Add_Delta_Days(@easter, $temp); } 217 &_check_init_date_($item,$name,$year,@date); 218 &_set_date_($self,$name,@date,$flag); 219 } 220 elsif (($item =~ /^ ([#:]?) (\d+) \. (\d+) \.? $/x) || 221 ($item =~ /^ ([#:]?) (\d+) \.? ([a-zA-Z]+) \.? $/x) || 222 ($item =~ /^ ([#:]?) (\d+) - (\d+|[a-zA-Z]+) -? $/x)) 223 { 224 $flag = $1; 225 @date = ($year,$3,$2); 226 &_set_fixed_date_($self,$item,$name,$year,$lang,@date,$flag); 227 } 228 elsif (($item =~ /^ ([#:]?) (\d+) \/ (\d+) $/x) || 229 ($item =~ /^ ([#:]?) ([a-zA-Z]+) \/? (\d+) $/x)) 230 { 231 $flag = $1; 232 @date = ($year,$2,$3); 233 &_set_fixed_date_($self,$item,$name,$year,$lang,@date,$flag); 234 } 235 elsif (($item =~ /^ ([#:]?) ([1-5]) ([a-zA-Z]+) (\d+) $/x) || 236 ($item =~ /^ ([#:]?) ([1-5]) \/ ([1-7]|[a-zA-Z]+) \/ (\d+|[a-zA-Z]+) $/x)) 237 { 238 $flag = $1; 239 $n = $2; 240 $dow = $3; 241 $temp = $4; 242 if ($dow =~ /^[a-zA-Z]+$/) 243 { 244 &_invalid_($item,$name) unless ($dow = Decode_Day_of_Week($dow,$lang)); 245 } 246 if ($temp =~ /^[a-zA-Z]+$/) 247 { 248 &_invalid_($item,$name) unless ($temp = Decode_Month($temp,$lang)); 249 } 250 else 251 { 252 &_invalid_($item,$name) unless (($temp > 0) && ($temp < 13)); 253 } 254 unless (@date = Nth_Weekday_of_Month_Year($year,$temp,$dow,$n)) 255 { 256 if ($n == 5) 257 { 258 &_invalid_($item,$name) 259 unless (@date = Nth_Weekday_of_Month_Year($year,$temp,$dow,4)); 260 } 261 else { &_invalid_($item,$name); } 262 } 263 &_set_date_($self,$name,@date,$flag); 264 } 265 else 266 { 267 croak("unrecognized date '$item' for day '$name'"); 268 } 269 } 270 ${$self}{'HALF'}->AndNot( ${$self}{'HALF'}, ${$self}{'FULL'} ); 271} 272 273sub vec_full # full holidays 274{ 275 my($self) = @_; 276 277 return ${$self}{'FULL'}; 278} 279 280sub vec_half # half holidays 281{ 282 my($self) = @_; 283 284 return ${$self}{'HALF'}; 285} 286 287sub vec_work # work space 288{ 289 my($self) = @_; 290 291 return ${$self}{'WORK'}; 292} 293 294sub val_days 295{ 296 my($self) = @_; 297 298 return ${$self}{'DAYS'}; 299} 300 301sub val_base 302{ 303 my($self) = @_; 304 305 return ${$self}{'BASE'}; 306} 307 308sub val_year 309{ 310 my($self) = @_; 311 312 return ${$self}{'YEAR'}; 313} 314 315sub year # as a shortcut and to enable shift_year 316{ 317 my($self) = @_; 318 319 return ${$self}{'YEAR'}; 320} 321 322sub labels 323{ 324 my($self) = shift; 325 my(@date); 326 my($index); 327 my(%result); 328 329 if (@_) 330 { 331 @date = shift_date(\@_); 332 $index = $self->date2index(@date); 333 if (defined $self->{'TAGS'}{$index}) 334 { 335 if (defined wantarray and wantarray) 336 { 337 return 338 ( 339 Day_of_Week_to_Text(Day_of_Week(@date)), 340 keys(%{$self->{'TAGS'}{$index}}) 341 ); 342 } 343 else 344 { 345 return 1 + scalar( keys(%{$self->{'TAGS'}{$index}}) ); 346 } 347 } 348 else 349 { 350 if (defined wantarray and wantarray) 351 { 352 return( Day_of_Week_to_Text(Day_of_Week(@date)) ); 353 } 354 else 355 { 356 return 1; 357 } 358 } 359 } 360 else 361 { 362 local($_); 363 %result = (); 364 foreach $index (keys %{$self->{'TAGS'}}) 365 { 366 grep( $result{$_} = 0, keys(%{$self->{'TAGS'}{$index}}) ); 367 } 368 if (defined wantarray and wantarray) 369 { 370 return( keys %result ); 371 } 372 else 373 { 374 return scalar( keys %result ); 375 } 376 } 377} 378 379sub search 380{ 381 my($self,$pattern) = @_; 382 my($index,$label,$upper); 383 my(@result); 384 385 local($_); 386 @result = (); 387 $pattern = ISO_UC($pattern); 388 foreach $index (keys %{$self->{'TAGS'}}) 389 { 390 LABEL: 391 foreach $label (keys %{$self->{'TAGS'}{$index}}) 392 { 393 $upper = ISO_UC($label); 394 if (index($upper,$pattern) >= $[) 395 { 396 push( @result, $index ); 397 last LABEL; 398 } 399 } 400 } 401 return( map( $self->index2date($_), sort {$a<=>$b} @result ) ); 402} 403 404sub tags 405{ 406 my($self) = shift; 407 my(%result) = (); 408 my($index); 409 my(@date); 410 411 if (@_ == 1 and not ref($_[0])) 412 { 413 $index = shift; 414 } 415 else 416 { 417 @date = shift_date(\@_); 418 $index = $self->date2index(@date); 419 } 420 if (exists $self->{'TAGS'}{$index} and 421 defined $self->{'TAGS'}{$index}) 422 { 423 %result = %{$self->{'TAGS'}{$index}}; 424 } 425 return \%result; 426} 427 428sub _interval_workdays_ 429{ 430 my($self,$lower,$upper) = @_; 431 my($work,$full,$half,$days); 432 433 $work = ${$self}{'WORK'}; 434 $full = ${$self}{'FULL'}; 435 $half = ${$self}{'HALF'}; 436 $work->Empty(); 437 $work->Interval_Fill($lower,$upper); 438 $work->AndNot($work,$full); 439 $days = $work->Norm(); 440 $work->And($work,$half); 441 $days -= $work->Norm() * 0.5; 442 return $days; 443} 444 445sub _delta_workdays_ 446{ 447 my($self,$lower_index,$upper_index,$include_lower,$include_upper) = @_; 448 my($days); 449 450 $days = ${$self}{'DAYS'}; 451 if (($lower_index < 0) || ($lower_index >= $days)) 452 { 453 croak("invalid lower index ($lower_index)"); 454 } 455 if (($upper_index < 0) || ($upper_index >= $days)) 456 { 457 croak("invalid upper index ($upper_index)"); 458 } 459 if ($lower_index > $upper_index) 460 { 461 croak("lower index ($lower_index) > upper index ($upper_index)"); 462 } 463 $lower_index++ unless ($include_lower); 464 $upper_index-- unless ($include_upper); 465 if (($upper_index < 0) || 466 ($lower_index >= $days) || 467 ($lower_index > $upper_index)) 468 { 469 &empty_period(); 470 return 0; 471 } 472 return $self->_interval_workdays_($lower_index,$upper_index); 473} 474 475sub delta_workdays 476{ 477 my($self) = shift; 478 my($yy1,$mm1,$dd1) = shift_date(\@_); 479 my($yy2,$mm2,$dd2) = shift_date(\@_); 480 my($including1,$including2) = (shift,shift); 481 my($index1,$index2); 482 483 $index1 = $self->date2index($yy1,$mm1,$dd1); 484 $index2 = $self->date2index($yy2,$mm2,$dd2); 485 if ($index1 > $index2) 486 { 487 return -$self->_delta_workdays_( 488 $index2,$index1,$including2,$including1); 489 } 490 else 491 { 492 return $self->_delta_workdays_( 493 $index1,$index2,$including1,$including2); 494 } 495} 496 497sub _move_forward_ 498{ 499 my($self,$index,$rest,$sign) = @_; 500 my($limit,$year,$full,$half,$loop,$min,$max); 501 502 if ($sign == 0) 503 { 504 return( $self->index2date($index), $rest, 0 ); 505 } 506 $limit = ${$self}{'DAYS'} - 1; 507 $year = ${$self}{'YEAR'}; 508 $full = ${$self}{'FULL'}; 509 $half = ${$self}{'HALF'}; 510 $loop = 1; 511 if ($sign > 0) 512 { 513 $rest = -$rest if ($rest < 0); 514 while ($loop) 515 { 516 $loop = 0; 517 if ($full->bit_test($index) && 518 (($min,$max) = $full->Interval_Scan_inc($index)) && 519 ($min == $index)) 520 { 521 if ($max >= $limit) 522 { 523 return( Date::Calc->new(++$year,1,1), $rest, +1 ); 524 } 525 else { $index = $max + 1; } 526 } 527 if ($half->bit_test($index)) 528 { 529 if ($rest >= 0.5) { $rest -= 0.5; $index++; $loop = 1; } 530 } 531 elsif ($rest >= 1.0) { $rest -= 1.0; $index++; $loop = 1; } 532 if ($loop && ($index > $limit)) 533 { 534 return( Date::Calc->new(++$year,1,1), $rest, +1 ); 535 } 536 } 537 return( $self->index2date($index), $rest, 0 ); 538 } 539 else # ($sign < 0) 540 { 541 $rest = -$rest if ($rest > 0); 542 while ($loop) 543 { 544 $loop = 0; 545 if ($full->bit_test($index) && 546 (($min,$max) = $full->Interval_Scan_dec($index)) && 547 ($max == $index)) 548 { 549 if ($min <= 0) 550 { 551 return( Date::Calc->new(--$year,12,31), $rest, -1 ); 552 } 553 else { $index = $min - 1; } 554 } 555 if ($half->bit_test($index)) 556 { 557 if ($rest <= -0.5) { $rest += 0.5; $index--; $loop = 1; } 558 } 559 elsif ($rest <= -1.0) { $rest += 1.0; $index--; $loop = 1; } 560 if ($loop && ($index < 0)) 561 { 562 return( Date::Calc->new(--$year,12,31), $rest, -1 ); 563 } 564 } 565 return( $self->index2date($index), $rest, 0 ); 566 } 567} 568 569sub add_delta_workdays 570{ 571 my($self) = shift; 572 my($yy,$mm,$dd) = shift_date(\@_); 573 my($days) = shift; 574 my($sign) = shift; 575 my($index,$full,$half,$limit,$diff,$guess); 576 577 $index = $self->date2index($yy,$mm,$dd); # check date 578 if ($sign == 0) 579 { 580 return( Date::Calc->new($yy,$mm,$dd), $days, 0 ); 581 } 582 $days = -$days if ($days < 0); 583 if ($days < 2) # other values possible for fine-tuning optimal speed 584 { 585 return( $self->_move_forward_($index,$days,$sign) ); 586 } 587 # else sufficiently large distance 588 $full = ${$self}{'FULL'}; 589 $half = ${$self}{'HALF'}; 590 if ($sign > 0) 591 { 592 # First, check against whole rest of year: 593 $limit = ${$self}{'DAYS'} - 1; 594 $diff = $self->_interval_workdays_($index,$limit); 595 if ($days >= $diff) 596 { 597 $days -= $diff; 598 return( Date::Calc->new(++$yy,1,1), $days, +1 ); 599 } 600 # else ($days < $diff) 601 # Now calculate proportional jump (approximatively): 602 $guess = $index + int($days * ($limit-$index+1) / $diff); 603 $guess = $limit if ($guess > $limit); 604 if ($index + 2 > $guess) # again, other values possible for fine-tuning 605 { 606 return( $self->_move_forward_($index,$days,+1) ); 607 } 608 # else sufficiently long jump 609 $diff = $self->_interval_workdays_($index,$guess-1); 610 while ($days < $diff) # reverse gear (jumped too far) 611 { 612 $guess--; 613 unless ($full->bit_test($guess)) 614 { 615 if ($half->bit_test($guess)) { $diff -= 0.5; } 616 else { $diff -= 1.0; } 617 } 618 } 619 # Now move in original direction: 620 $days -= $diff; 621 return( $self->_move_forward_($guess,$days,+1) ); 622 } 623 else # ($sign < 0) 624 { 625 # First, check against whole rest of year: 626 $limit = 0; 627 $diff = $self->_interval_workdays_($limit,$index); 628 if ($days >= $diff) 629 { 630 $days -= $diff; 631 return( Date::Calc->new(--$yy,12,31), -$days, -1 ); 632 } 633 # else ($days < $diff) 634 # Now calculate proportional jump (approximatively): 635 $guess = $index - int($days * ($index+1) / $diff); 636 $guess = $limit if ($guess < $limit); 637 if ($guess > $index - 2) # again, other values possible for fine-tuning 638 { 639 return( $self->_move_forward_($index,-$days,-1) ); 640 } 641 # else sufficiently long jump 642 $diff = $self->_interval_workdays_($guess+1,$index); 643 while ($days < $diff) # reverse gear (jumped too far) 644 { 645 $guess++; 646 unless ($full->bit_test($guess)) 647 { 648 if ($half->bit_test($guess)) { $diff -= 0.5; } 649 else { $diff -= 1.0; } 650 } 651 } 652 # Now move in original direction: 653 $days -= $diff; 654 return( $self->_move_forward_($guess,-$days,-1) ); 655 } 656} 657 658sub is_full 659{ 660 my($self) = shift; 661 my(@date) = shift_date(\@_); 662 663 return $self->vec_full->bit_test( $self->date2index(@date) ); 664} 665 666sub is_half 667{ 668 my($self) = shift; 669 my(@date) = shift_date(\@_); 670 671 return $self->vec_half->bit_test( $self->date2index(@date) ); 672} 673 674sub is_work 675{ 676 my($self) = shift; 677 my(@date) = shift_date(\@_); 678 679 return $self->vec_work->bit_test( $self->date2index(@date) ); 680} 681 6821; 683 684__END__ 685 686