"Fossies" - the Fresh Open Source Software Archive

Member "Date-Calc-6.4/lib/Date/Calendar/Year.pm" (7 Mar 2015, 18082 Bytes) of package /linux/privat/Date-Calc-6.4.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Year.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 6.3_vs_6.4.

    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 
   12 package Date::Calendar::Year;
   13 
   14 BEGIN { eval { require bytes; }; }
   15 use strict;
   16 use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION );
   17 
   18 require 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 
   30 use Bit::Vector;
   31 use Carp::Clan qw(^Date::);
   32 use Date::Calc::Object qw(:ALL);
   33 
   34 sub 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 
   44 sub empty_period
   45 {
   46     carp("dates interval is empty") if ($^W);
   47 }
   48 
   49 sub _invalid_
   50 {
   51     my($item,$name) = @_;
   52 
   53     croak("date '$item' for day '$name' is invalid");
   54 }
   55 
   56 sub _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 
   64 sub _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 
   72 sub _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 
   88 sub _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 
  104 sub 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 
  124 sub 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 
  144 sub 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 
  160 sub 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 
  273 sub vec_full # full holidays
  274 {
  275     my($self) = @_;
  276 
  277     return ${$self}{'FULL'};
  278 }
  279 
  280 sub vec_half # half holidays
  281 {
  282     my($self) = @_;
  283 
  284     return ${$self}{'HALF'};
  285 }
  286 
  287 sub vec_work # work space
  288 {
  289     my($self) = @_;
  290 
  291     return ${$self}{'WORK'};
  292 }
  293 
  294 sub val_days
  295 {
  296     my($self) = @_;
  297 
  298     return ${$self}{'DAYS'};
  299 }
  300 
  301 sub val_base
  302 {
  303     my($self) = @_;
  304 
  305     return ${$self}{'BASE'};
  306 }
  307 
  308 sub val_year
  309 {
  310     my($self) = @_;
  311 
  312     return ${$self}{'YEAR'};
  313 }
  314 
  315 sub year # as a shortcut and to enable shift_year
  316 {
  317     my($self) = @_;
  318 
  319     return ${$self}{'YEAR'};
  320 }
  321 
  322 sub 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 
  379 sub 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 
  404 sub 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 
  428 sub _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 
  445 sub _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 
  475 sub 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 
  497 sub _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 
  569 sub 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 
  658 sub 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 
  666 sub 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 
  674 sub 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 
  682 1;
  683 
  684 __END__
  685