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