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