File Coverage

blib/lib/Date/Holidays/BY.pm
Criterion Covered Total %
statement 80 81 98.7
branch 34 46 73.9
condition 10 15 66.6
subroutine 16 16 100.0
pod 5 5 100.0
total 145 163 88.9


line stmt bran cond sub pod time code
1             package Date::Holidays::BY;
2             our $VERSION = '1.2023.2'; # VERSION
3              
4             =encoding utf8
5              
6             =head1 NAME
7              
8             Date::Holidays::BY - Determine Belorussian official holidays and business days.
9              
10             =head1 SYNOPSIS
11              
12             use Date::Holidays::BY qw( is_holiday holidays is_business_day );
13              
14             my ( $year, $month, $day ) = ( localtime )[ 5, 4, 3 ];
15             $year += 1900;
16             $month += 1;
17              
18             if ( my $holidayname = is_holiday( $year, $month, $day ) ) {
19             print "Today is a holiday: $holidayname\n";
20             }
21              
22             my $ref = holidays( $year );
23             while ( my ( $md, $name ) = each %$ref ) {
24             print "On $md there is a holiday named $name\n";
25             }
26              
27             if ( is_business_day( 2012, 03, 11 ) ) {
28             print "2012-03-11 is business day on weekend\n";
29             }
30              
31             if ( is_short_business_day( 2015, 04, 30 ) ) {
32             print "2015-04-30 is short business day\n";
33             }
34              
35             $Date::Holidays::BY::strict=1;
36             # here we die because time outside from $HOLIDAYS_VALID_SINCE to $INACCURATE_TIMES_SINCE
37             holidays( 9001 );
38              
39             =cut
40              
41 5     5   362647 use warnings;
  5         61  
  5         165  
42 5     5   27 use strict;
  5         16  
  5         133  
43 5     5   25 use utf8;
  5         11  
  5         45  
44 5     5   165 use base 'Exporter';
  5         10  
  5         762  
45 5     5   36 use Carp;
  5         19  
  5         565  
46              
47             our @EXPORT_OK = qw(
48             is_holiday
49             is_by_holiday
50             holidays
51             is_business_day
52             is_short_business_day
53             );
54              
55             =head2 $Date::Holidays::BY::HOLIDAYS_VALID_SINCE, $Date::Holidays::BY::INACCURATE_TIMES_SINCE
56              
57             HOLIDAYS_VALID_SINCE before this year package doesn't matter
58             INACCURATE_TIMES_SINCE after this year dates of holidays and working day shift are not accurate, but you can most likely be sure of historical holidays
59              
60             =cut
61              
62 5     5   38 use List::Util;
  5         8  
  5         7323  
63              
64             our $HOLIDAYS_VALID_SINCE = 2013; # TODO add all old
65             our $INACCURATE_TIMES_SINCE = 2024;
66              
67             =head2 $Date::Holidays::BY::strict
68              
69             Allows you to return an error if the requested date is outside the determined times.
70             Default is 0.
71              
72             =cut
73              
74             our $strict = 0;
75              
76             # internal date formatting alike ISO 8601: MMDD
77             my @REGULAR_HOLIDAYS = (
78             {
79             name => 'Новый год',
80             days => {
81             1992 => '0101',
82             2020 => [ qw( 0101 0102 ) ],
83             },
84             },
85             {
86             name => 'Международный женский день',
87             days => '0308',
88             },
89             {
90             name => 'Праздник труда',
91             days => '0501',
92             },
93             {
94             name => 'День Победы',
95             days => '0509',
96             },
97             {
98             name => 'День Независимости Республики Беларусь',
99             days => '0703',
100             },
101             {
102             name => 'День Октябрьской революции',
103             days => '1107',
104             },
105             {
106             name => 'Рождество Христово (православное Рождество)',
107             days => '0107',
108             },
109             {
110             name => 'Рождество Христово (католическое Рождество)',
111             days => '1225',
112             },
113             {
114             name => 'Радоница',
115             days => \&_radonitsa_mmdd,
116             },
117             );
118              
119             my %HOLIDAYS_SPECIAL = (
120             2013 => [ qw( 0102 0510 ) ],
121             2014 => [ qw( 0102 0106 0430 0704 1226 ) ],
122             2015 => [ qw( 0102 0420 ) ],
123             2016 => [ qw( 0108 0307 ) ],
124             2017 => [ qw( 0102 0424 0425 0508 1106 ) ],
125             2018 => [ qw( 0102 0309 0416 0417 0430 0702 1224 1231 ) ],
126             2019 => [ qw( 0506 0507 0508 1108 ) ],
127             2020 => [ qw( 0106 0427 0428 ) ],
128             2021 => [ qw( 0108 0510 0511 ) ],
129             2022 => [ qw( 0307 0502 ) ],
130             2023 => [ qw( 0424 0508 1106 ) ],
131             );
132              
133             my %BUSINESS_DAYS_ON_WEEKENDS = (
134             2013 => [ qw( 0105 0518 ) ],
135             2014 => [ qw( 0104 0111 0503 0712 1220 ) ],
136             2015 => [ qw( 0110 0425 ) ],
137             2016 => [ qw( 0116 0305 ) ],
138             2017 => [ qw( 0121 0429 0506 1104 ) ],
139             2018 => [ qw( 0120 0303 0414 0428 0707 1222 1229 ) ],
140             2019 => [ qw( 0504 0511 1116 ) ],
141             2020 => [ qw( 0104 0404 ) ],
142             2021 => [ qw( 0116 0515 ) ],
143             2022 => [ qw( 0312 0514 ) ],
144             2023 => [ qw( 0429 0513 1111 ) ],
145             );
146              
147             my %SHORT_BUSINESS_DAYS = (
148             2014 => [ qw( 0428 0508 0702 1106 1224 1231 ) ],
149             2015 => [ qw( 0106 0430 0508 0702 1106 1224 ) ],
150             2016 => [ qw( 0106 ) ],
151             2017 => [ qw( 0106 0307 0429 0506 1104 ) ],
152             2018 => [ qw( 0307 0508 1106 ) ],
153             2019 => [ qw( 0307 0430 0506 0702 1106 1224 ) ],
154             2020 => [ qw( ) ],
155             2021 => [ qw( ) ],
156             2022 => [ qw( ) ],
157             2023 => [ qw( ) ],
158             );
159              
160              
161              
162             sub _radonitsa_mmdd {
163 11     11   100 my $year=$_[0];
164 11 50       28 if ($year < 1583) {croak "Module has limitation in counting Easter outside the period 1583-7666";}
  0         0  
165 11         1994 require Date::Easter;
166 11         15236 my ($easter_month, $easter_day) = Date::Easter::orthodox_easter($year);
167 11         1127 my $radonitsa_month = $easter_month;
168 11         26 my $radonitsa_day = $easter_day + 9;
169 11 100       36 if ( $radonitsa_day > 30 ) {
170 2         5 $radonitsa_month++;
171 2         5 $radonitsa_day -= 30;
172             }
173 11         52 return _get_date_key($radonitsa_month, $radonitsa_day);
174             }
175              
176             =head2 is_holiday( $year, $month, $day )
177              
178             Determine whether this date is a BY holiday. Returns holiday name or undef.
179              
180             =cut
181              
182             sub is_holiday {
183 15     15 1 4632 my ( $year, $month, $day ) = @_;
184 15 100 100     123 croak 'Bad params' unless $year && $month && $day;
      66        
185              
186 13         41 return holidays( $year )->{ _get_date_key($month, $day) };
187             }
188              
189             =head2 is_by_holiday( $year, $month, $day )
190              
191             Alias for is_holiday().
192              
193             =cut
194              
195             sub is_by_holiday {
196 1     1 1 92 goto &is_holiday;
197             }
198              
199             =head2 holidays( $year )
200              
201             Returns hash ref of all BY holidays in the year.
202              
203             =cut
204              
205             my %cache;
206             sub holidays {
207 17 50   17 1 1892 my $year = shift or croak 'Bad year';
208              
209 17 100       66 return $cache{ $year } if $cache{ $year };
210              
211 11         46 my $holidays = _get_regular_holidays_by_year($year);
212              
213 8 100       38 if ( my $spec = $HOLIDAYS_SPECIAL{ $year } ) {
214 6         41 $holidays->{ $_ } = 'Перенос праздничного дня' for @$spec;
215             }
216              
217 8         35 return $cache{ $year } = $holidays;
218             }
219              
220             sub _get_regular_holidays_by_year {
221 11     11   22 my ($year) = @_;
222 11 100       84 croak "BY holidays is not valid before $HOLIDAYS_VALID_SINCE" if $year < $HOLIDAYS_VALID_SINCE;
223 9 100       40 if ($strict) {
224 1 50       10 croak "BY holidays is not valid after @{[ $INACCURATE_TIMES_SINCE - 1 ]}" if $year >= $INACCURATE_TIMES_SINCE;
  1         15  
225             }
226              
227 8         17 my %day;
228 8         26 for my $holiday (@REGULAR_HOLIDAYS) {
229 72         138 my $days = _resolve_yhash_value($holiday->{days}, $year);
230 72 50       137 next if !$days;
231 72 100       156 $days = [$days] if !ref $days;
232 72 50       136 next if !@$days;
233              
234 72         126 my $name = _resolve_yhash_value($holiday->{name}, $year);
235 72 50       128 croak "Name is not defined" if !$name; # assertion
236              
237 72         225 $day{$_} = $name for @$days;
238             }
239              
240 8         34 return \%day;
241             }
242              
243             sub _resolve_yhash_value {
244 144     144   241 my ($value, $year) = @_;
245 144 100       283 return $value->($year) if ref $value eq 'CODE';
246 136 100       323 return $value if ref $value ne 'HASH';
247              
248 8     12   86 my $ykey = List::Util::first {$year >= $_} reverse sort keys %$value;
  12         37  
249 8 50       37 return if !$ykey;
250 8 50       26 return $value->{$ykey}->($year) if ref $value->{$ykey} eq 'CODE';
251 8         21 return $value->{$ykey};
252             }
253              
254              
255             =head2 is_business_day( $year, $month, $day )
256              
257             Returns true if date is a business day in BY taking holidays and weekends into account.
258              
259             =cut
260              
261             sub is_business_day {
262 5     5 1 102 my ( $year, $month, $day ) = @_;
263              
264 5 50 33     31 croak 'Bad params' unless $year && $month && $day;
      33        
265              
266 5 50       14 return 0 if is_holiday( $year, $month, $day );
267              
268             # check if date is a weekend
269 5         623 require Time::Piece;
270 5         12348 my $t = Time::Piece->strptime( "$year-$month-$day", '%Y-%m-%d' );
271 5         312 my $wday = $t->day;
272 5 100 100     114 return 1 unless $wday eq 'Sat' || $wday eq 'Sun';
273              
274             # check if date is a business day on weekend
275 4 50       15 my $ref = $BUSINESS_DAYS_ON_WEEKENDS{ $year } or return 0;
276              
277 4         10 my $md = _get_date_key($month, $day);
278 4         10 for ( @$ref ) {
279 13 100       30 return 1 if $_ eq $md;
280             }
281              
282 3         16 return 0;
283             }
284              
285             =head2 is_short_business_day( $year, $month, $day )
286              
287             Returns true if date is a shortened business day in BY.
288              
289             =cut
290              
291             sub is_short_business_day {
292 3     3 1 90 my ( $year, $month, $day ) = @_;
293              
294 3 50       14 my $short_days_ref = $SHORT_BUSINESS_DAYS{ $year } or return 0;
295              
296 3         8 my $date_key = _get_date_key($month, $day);
297 3         7 return !!grep { $_ eq $date_key } @$short_days_ref;
  16         43  
298             }
299              
300              
301             sub _get_date_key {
302 28     28   86 my ($month, $day) = @_;
303 28         164 return sprintf '%02d%02d', $month, $day;
304             }
305              
306             =head1 LICENSE
307              
308             This software is copyright (c) 2023 by Vladimir Varlamov.
309              
310             This is free software; you can redistribute it and/or modify it under
311             the same terms as the Perl 5 programming language system itself.
312              
313             Terms of the Perl programming language system itself
314              
315             a) the GNU General Public License as published by the Free
316             Software Foundation; either version 1, or (at your option) any
317             later version, or
318             b) the "Artistic License"
319              
320             =cut
321              
322              
323             =head1 AUTHOR
324              
325             Vladimir Varlamov, C<< >>
326              
327             =cut
328              
329              
330              
331             1;