File Coverage

blib/lib/PFT/Date.pm
Criterion Covered Total %
statement 63 66 95.4
branch 50 64 78.1
condition 2 6 33.3
subroutine 18 18 100.0
pod 7 10 70.0
total 140 164 85.3


line stmt bran cond sub pod time code
1             # Copyright 2014-2016 - Giovanni Simoni
2             #
3             # This file is part of PFT.
4             #
5             # PFT is free software: you can redistribute it and/or modify it under the
6             # terms of the GNU General Public License as published by the Free
7             # Software Foundation, either version 3 of the License, or (at your
8             # option) any later version.
9             #
10             # PFT is distributed in the hope that it will be useful, but WITHOUT ANY
11             # WARRANTY; without even the implied warranty of MERCHANTABILITY or
12             # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with PFT. If not, see .
17             #
18             package PFT::Date v1.3.0;
19              
20             =pod
21              
22             =encoding utf8
23              
24             =head1 NAME
25              
26             PFT::Date - Representation of date
27              
28             =head1 SYNOPSIS
29              
30             PFT::Date->new(2016, 12, 10)
31              
32             PFT::Date->from_spec(
33             d => 12,
34             m => 'june', # human friendly
35             # missing ones (e.g. year) filled with today's year.
36             )
37              
38             PFT::Date->from_string('1955-11-05');
39              
40             =head1 DESCRIPTION
41              
42             C is defined as a blessed array reference. The first element is
43             the year, the second is the month, the third is the day.
44              
45             =cut
46              
47 8     8   1111 use utf8;
  8         21  
  8         52  
48 8     8   280 use v5.16;
  8         26  
49 8     8   43 use strict;
  8         15  
  8         164  
50 8     8   125 use warnings;
  8         20  
  8         251  
51              
52 8     8   45 use Carp;
  8         15  
  8         2051  
53              
54             use overload
55 429     429   2407 '""' => sub { shift->repr('-') },
56             '<=>' => sub {
57 640     640   2662 my($self, $othr, $swap) = @_;
58              
59 640 50       1451 $othr->isa('PFT::Date') or
60             confess "Assumed date-to-date comparison";
61              
62 640 50       1391 my $out = (defined $self->[0] ? $self->[0] : 0)
    100          
63             <=> (defined $othr->[0] ? $othr->[0] : 0);
64 640 100       1045 if ($out == 0) {
65 587 50       1136 $out = (defined $self->[1] ? $self->[1] : 1)
    100          
66             <=> (defined $othr->[1] ? $othr->[1] : 1)
67             }
68 640 100       1037 if ($out == 0) {
69 478 100       971 $out = (defined $self->[2] ? $self->[2] : 1)
    100          
70             <=> (defined $othr->[2] ? $othr->[2] : 1)
71             }
72 640 50       1474 $swap ? -$out : $out;
73             }
74 8     8   1171 ;
  8         1059  
  8         115  
75              
76             sub new {
77 837     837 0 6541 my $cls = shift;
78 837 100       6007 my $self = bless [map defined($_) ? int : undef, @_[0 .. 2]], $cls;
79              
80 837 100       2393 defined $self->[1] and do {
81 830 50 33     3436 $self->[1] > 0 && $self->[1] < 13 or confess "Month $self->[1]"
82             };
83              
84 837 100       1606 defined $self->[2] and do {
85 809 50 33     2365 $self->[2] > 0 && $self->[2] < 32 or confess "Day $self->[2]"
86             };
87              
88 837         3860 $self
89             }
90              
91             my %MONTHS = (
92             ja => 1,
93             f => 2,
94             mar => 3,
95             ap => 4,
96             may => 5,
97             jun => 6,
98             jul => 7,
99             au => 8,
100             s => 9,
101             o => 10,
102             n => 11,
103             d => 12,
104             );
105              
106             sub from_spec {
107 1     1 0 3 my $cls = shift;
108 1         5 my %params = @_;
109              
110 1         46 my($y, $m, $d) = (localtime)[5, 4, 3];
111              
112 1 50       6 exists $params{d} or $params{d} = $d;
113 1 50       6 if (local $_ = $params{m}) {
114 1 50       12 if (/^\d{1,2}$/) {
    50          
115 0         0 $params{m} = int($_)
116             } elsif (m/^(j(?:a|u[nl])|[fsond]|ma[ry]|a[pu]).*/i) {
117 1         6 $params{m} = $MONTHS{lc $1}
118             } else {
119 0         0 croak "Invalid month: $_";
120             }
121             } else {
122 0         0 $params{m} = $m + 1;
123             }
124 1 50       4 exists $params{y} or $params{y} = $y + 1900;
125              
126 1         4 $cls->new(@params{qw/y m d/});
127             }
128              
129             sub from_string {
130 128     128 0 1047 my $cls = shift;
131 128         201 my $text = shift;
132              
133 128 100       1075 my ($y, $m, $d) = $text =~ m/^(\d{4}|\*)-(\d{2}|\*)-(\d{2}|\*)$/
134             or croak "Date \"$text\" not in YYYY-MM-DD format";
135              
136 127 50       860 $cls->new(
    50          
    100          
137             $y ne '*' ? int($y) : undef,
138             $m ne '*' ? int($m) : undef,
139             $d ne '*' ? int($d) : undef
140             )
141             }
142              
143             =head2 Properties
144              
145             =over
146              
147             =item y
148              
149             Year getter
150              
151             =item m
152              
153             Month getter
154              
155             =item d
156              
157             Day getter
158              
159             =cut
160              
161 127     127 1 470 sub y { shift->[0] }
162 122     122 1 485 sub m { shift->[1] }
163 95     95 1 281 sub d { shift->[2] }
164              
165             =item to_hash
166              
167             Returns a dictionary in the form
168              
169             { y => ..., m => ..., d => ... }
170              
171             =cut
172              
173             sub to_hash {
174 2     2 1 3 my %out;
175 2         3 @out{qw/y m d/} = @{shift()};
  2         7  
176 2         13 \%out;
177             }
178              
179             =item repr
180              
181             Returns a string representing the date. Optional parameter is a separator
182             string, by default C<'-'>
183              
184             PFT::Date->new(1,2,3)->repr eq '0001-02-03'
185             PFT::Date->new(1,2,3)->repr('/') eq '0001/02/03'
186              
187             =cut
188              
189             sub repr {
190 489     489 1 624 my $self = shift;
191 489         615 my $sep = shift;
192 489         577 my $none = shift;
193              
194 489 50       941 $none = '*' unless defined $none;
195 489 100       3535 join defined $sep ? $sep : '-',
    100          
    100          
    100          
196             defined $self->[0] ? sprintf('%04d', $self->[0]) : $none,
197             defined $self->[1] ? sprintf('%02d', $self->[1]) : $none,
198             defined $self->[2] ? sprintf('%02d', $self->[2]) : $none;
199             }
200              
201             =item derive
202              
203             Returns a copy of the PFT::Date object with the provided components
204             replaced.
205              
206             PFT::Date->new(1, 2, 3)->derive(m => undef)
207              
208             is like
209              
210             PFT::Date->new(1, undef, 3)
211              
212             =cut
213              
214             sub derive {
215 12     12 1 19 my $self = shift;
216 12         31 my %change = @_;
217             PFT::Date->new(
218             exists $change{y} ? $change{y} : $self->y,
219             exists $change{m} ? $change{m} : $self->m,
220 12 100       36 exists $change{d} ? $change{d} : $self->d,
    100          
    100          
221             )
222             }
223              
224             =item complete
225              
226             Check if the date is complete of year, month and day.
227              
228             =cut
229              
230             sub complete {
231 231     231 1 314 3 == scalar grep defined, @{shift()}
  231         1237  
232             }
233              
234             =back
235              
236             =cut
237              
238             1;