File Coverage

lib/Date/Cutoff/JP.pm
Criterion Covered Total %
statement 59 59 100.0
branch 8 10 80.0
condition 5 5 100.0
subroutine 12 12 100.0
pod 1 1 100.0
total 85 87 97.7


line stmt bran cond sub pod time code
1             package Date::Cutoff::JP;
2 7     7   423371 use 5.008001;
  7         87  
3 7     7   37 use strict;
  7         9  
  7         164  
4 7     7   58 use warnings;
  7         31  
  7         361  
5              
6             our $VERSION = "0.07";
7              
8 7     7   41 use Carp;
  7         10  
  7         466  
9 7     7   3135 use Time::Seconds;
  7         22267  
  7         436  
10 7     7   3450 use Time::Piece;
  7         57376  
  7         27  
11             my $tp = Time::Piece->new();
12 7     7   3973 use Calendar::Japanese::Holiday;
  7         22542  
  7         435  
13 7     7   3133 use Date::DayOfWeek;
  7         10745  
  7         343  
14              
15 7     7   3709 use Moose;
  7         3215713  
  7         55  
16              
17             has cutoff => ( is => 'rw', isa => 'Int', default => 0 );
18             has payday => ( is => 'rw', isa => 'Int', default => 0 );
19             has late => ( is => 'rw', isa => 'Int', default => 1 );
20              
21             around 'cutoff' => sub {
22             my $orig = shift;
23             my $self = shift;
24             return $self->$orig() unless @_;
25              
26             my $value = shift;
27             croak "unvalid cutoff was set: $value" if $value < 0 or 28 < $value;
28             my $day = $value? $value: 31;
29             croak "cuttoff must be before payday"
30             if $day >= $self->payday and $self->late == 0;
31             return $self->$orig($value);
32             };
33              
34             around 'payday' => sub {
35             my $orig = shift;
36             my $self = shift;
37             return $self->$orig() unless @_;
38            
39             my $value = shift;
40             croak "unvalid payday was set: $value" if $value < 0 or 28 < $value;
41             my $day = $value? $value: 31;
42             croak "payday must be after cuttoff"
43             if $day <= $self->cutoff and $self->late == 0;
44             return $self->$orig($value);
45             };
46              
47             around 'late' => sub {
48             my $orig = shift;
49             my $self = shift;
50             return $self->$orig() unless @_;
51             my $value = shift;
52             croak "unvalid lateness was set: $value" if $value < 0 or 2 < $value;
53             croak "payday is before cuttoff in same month"
54             if $value == 0 and $self->payday <= $self->cutoff;
55             return $self->$orig($value);
56             };
57              
58             __PACKAGE__->meta->make_immutable;
59 7     7   54744 no Moose;
  7         15  
  7         38  
60              
61             sub _isWeekend {
62 278     278   2388 my $self = shift;
63 278         953 my ($y, $m, $d ) = split "-", shift;
64 278         776 my $dow = dayofweek( $d, $m, $y );
65 278   100     10330 return isHoliday( $y, 0+$m, 0+$d, 1 ) || $dow == 6 || $dow == 0;
66             }
67              
68             sub calc_date {
69 72     72 1 74939 my $self = shift;
70 72 50       210 my $until = shift if @_;
71 72 50       601 my $t = $until? $tp->strptime( $until, '%Y-%m-%d' ) : localtime();
72            
73 72 100       7658 my $cutoff = $self->cutoff? $self->cutoff: $t->month_last_day();
74 72         658 my $str = $t->strftime('%Y-%m-') . sprintf( "%02d", $cutoff );
75 72         2840 my $ref_day = $t->strptime( $str, '%Y-%m-%d');
76 72         6011 my $over = 0;
77 72 100       177 if ( $ref_day->epoch() < $t->epoch() ) {
78 12         122 $over = 1;
79 12         26 $ref_day += ONE_DAY() * $ref_day->month_last_day();
80             }
81            
82 72         1526 $cutoff = $ref_day->ymd();
83 72         1155 while( $self->_isWeekend($cutoff) ){
84 60         19309 my $ref_day = $t->strptime( $cutoff, '%Y-%m-%d');
85 60         4973 $ref_day += ONE_DAY();
86 60         3321 $cutoff = $ref_day->ymd();
87             }
88            
89 72   100     16801 $ref_day += ONE_DAY() * 28 * ( $self->late || 0 );
90 72         4631 $str = $ref_day->strftime('%Y-%m-%d');
91 72         2169 $ref_day = $t->strptime( $str, '%Y-%m-%d');
92              
93 72 100       6201 my $payday = $self->payday? $self->payday: $ref_day->month_last_day();
94 72         923 $str = $ref_day->strftime('%Y-%m-') . sprintf( "%02d", $payday );
95            
96 72         2621 my $date = $t->strptime( $str, '%Y-%m-%d' )->ymd();
97 72         7246 while( $self->_isWeekend($date) ){
98 74         23130 my $ref_day = $t->strptime( $date, '%Y-%m-%d');
99 74         6220 $ref_day += ONE_DAY();
100 74         4164 $date = $ref_day->ymd();
101             }
102 72         19622 return ( cutoff => $cutoff, payday => $date, is_over => $over );
103             }
104              
105             1;
106             __END__
107              
108             =encoding utf-8
109              
110             =head1 NAME
111              
112             Date::CutOff::JP - Get the day cutoff and payday for in Japanese timezone
113              
114             =head1 SYNOPSIS
115              
116             use Date::CutOff::JP;
117             my $dco = Date::CutOff::JP->new({ cutoff => 0, late => 1, payday => 0 });
118             my %calculated = $dco->calc_date('2019-01-01');
119             print $calculated{'cutoff'}; # '2019-01-31'
120             print $calculated{'payday'}; # '2019-02-28'
121              
122             =head1 DESCRIPTION
123              
124             Date::CutOff::JP provides how to calculate the day cutoff and the payday from Japanese calendar.
125              
126             You can calculate the weekday for cutoff and paying without holidays in Japan.
127            
128             =head1 Constructor
129              
130             =head3 new({ [cutoff => $day], [payday => $day], [late => 0||1||2] })
131            
132             You may omit parameters. defaults are { cutoff => 0, payday => 0, late => 1 }
133            
134             =head2 Accessor Methods
135            
136             =head3 cutoff()
137            
138             get/set the day cutoff in every months. 0 means the end of the month.
139            
140             B<caution> Int over 28 is denied
141              
142             =head3 payday()
143            
144             get/set the payday in every months. 0 means the end of the month.
145            
146             B<caution> Int over 28 is denied
147              
148             =head3 late()
149            
150             get/set the lateness. 0 means the cutoff and payday is at same month.
151              
152             The all you can set is Int of [ 0 .. 2 ] 3 or more returns error.
153            
154             =head2 Method
155              
156             =head3 calc_date([$date])
157              
158             You may omit the parameter. default is TODAY.
159            
160             returns hash value with keys below:
161              
162             =over
163            
164             =item cutoff
165              
166             The latest cutoff after $date.
167            
168             =item payday
169            
170             The latest payday after $date.
171              
172             =item is_over ( maybe bad key name )
173            
174             Is or not that the cutoff is pending until next month.
175              
176             =back
177            
178             =head1 BUGS
179              
180             =head1 SEE ALSO
181            
182             L<Calendar::Japanese::Holiday>,L<Date::DayOfWeek>
183            
184             L<日本の祝日YAML|https://github.com/holiday-jp/holiday_jp/blob/master/holidays.yml>
185            
186             =head1 LICENSE
187              
188             Copyright (C) worthmine.
189              
190             This library is free software; you can redistribute it and/or modify
191             it under the same terms as Perl itself.
192              
193             =head1 AUTHOR
194              
195             worthmine E<lt>worthmine@cpan.orgE<gt>
196            
197             =cut