File Coverage

File:C4/Dates.pm
Coverage:80.3%

linestmtbrancondsubtimecode
1package C4::Dates;
2
3# This file is part of Koha.
4#
5# Koha 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 Software
7# Foundation; either version 2 of the License, or (at your option) any later
8# version.
9#
10# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
11# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13#
14# You should have received a copy of the GNU General Public License along with
15# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
16# Suite 330, Boston, MA 02111-1307 USA
17
18
29
29
29
29
116731
169
1114
use strict;
19
29
29
29
29
283
142
1253
use warnings;
20
29
29
29
29
306
229
2240
use Carp;
21
29
29
29
29
552
207
676
use C4::Context;
22
29
29
29
29
279
182
3786
use C4::Debug;
23
29
29
29
29
198
101
1393
use Exporter;
24
29
29
29
29
209
92
547
use POSIX qw(strftime);
25
29
29
29
29
95969
106355
4187
use Date::Calc qw(check_date check_time);
26
29
29
29
29
321
195
3375
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
27
29
29
29
29
306
165
1997
use vars qw($debug $cgi_debug);
28
29BEGIN {
30
29
29
194
    $VERSION = 0.04;
31
29
469
    @ISA = qw(Exporter);
32
29
910
    @EXPORT_OK = qw(format_date_in_iso format_date);
33}
34
35
29
29
29
29
246
122
59475
use vars qw($prefformat);
36
37sub _prefformat {
38
143
50
143
739
    unless ( defined $prefformat ) {
39
0
0
        $prefformat = C4::Context->preference('dateformat');
40    }
41
143
364
    return $prefformat;
42}
43
44sub reset_prefformat { # subroutine to clear the prefformat, called when we change it
45
0
0
0
0
    if (defined $prefformat){
46
0
0
        $prefformat = C4::Context->preference('dateformat');
47    }
48}
49
50our %format_map = (
51    iso => 'yyyy-mm-dd', # plus " HH:MM:SS"
52    metric => 'dd/mm/yyyy', # plus " HH:MM:SS"
53    us => 'mm/dd/yyyy', # plus " HH:MM:SS"
54    sql => 'yyyymmdd HHMMSS',
55    rfc822 => 'a, dd b y HH:MM:SS z ',
56);
57our %posix_map = (
58    iso => '%Y-%m-%d', # or %F, "Full Date"
59    metric => '%d/%m/%Y',
60    us => '%m/%d/%Y',
61    sql => '%Y%m%d %H%M%S',
62    rfc822 => '%a, %d %b %Y %H:%M:%S %z',
63);
64
65our %dmy_subs = ( # strings to eval (after using regular expression returned by regexp below)
66                                      # make arrays for POSIX::strftime()
67    iso => '[(($6||0),($5||0),($4||0),$3, $2 - 1, $1 - 1900)]',
68    metric => '[(($6||0),($5||0),($4||0),$1, $2 - 1, $3 - 1900)]',
69    us => '[(($6||0),($5||0),($4||0),$2, $1 - 1, $3 - 1900)]',
70    sql => '[(($6||0),($5||0),($4||0),$3, $2 - 1, $1 - 1900)]',
71    rfc822 => '[($7, $6, $5, $2, $3, $4 - 1900, $8)]',
72);
73
74our @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
75
76our @days = qw(Sun Mon Tue Wed Thu Fri Sat);
77
78sub regexp ($;$) {
79
70
70
1978
    my $self = shift;
80
70
274
    my $delim = qr/:?\:|\/|-/; # "non memory" cluster: no backreference
81
70
100
33
261
    my $format = (@_) ? _recognize_format(shift) : ( $self->{'dateformat'} || _prefformat() );
82
83    # Extra layer of checking $self->{'dateformat'}.
84    # Why? Because it is assumed you might want to check regexp against an *instantiated* Dates object as a
85    # way of saying "does this string match *whatever* format that Dates object is?"
86
87
70
100
236
    ( $format eq 'sql' )
88      and return qr/^(\d{4})(\d{1,2})(\d{1,2})(?:\s{4}(\d{2})(\d{2})(\d{2}))?/;
89
62
100
385
    ( $format eq 'iso' )
90      and return qr/^(\d{4})$delim(\d{1,2})$delim(\d{1,2})(?:(?:\s{1}|T)(\d{2})\:?(\d{2})\:?(\d{2}))?Z?/;
91
38
100
108
    ( $format eq 'rfc822' )
92      and return qr/^([a-zA-Z]{3}),\s{1}(\d{1,2})\s{1}([a-zA-Z]{3})\s{1}(\d{4})\s{1}(\d{1,2})\:(\d{1,2})\:(\d{1,2})\s{1}(([\-|\+]\d{4})|([A-Z]{3}))/;
93
34
412
    return qr/^(\d{1,2})$delim(\d{1,2})$delim(\d{4})(?:\s{1}(\d{1,2})\:?(\d{1,2})\:?(\d{1,2}))?/; # everything else
94}
95
96sub dmy_map ($$) {
97
40
40
65
    my $self = shift;
98
40
50
118
    my $val = shift or return undef;
99
40
50
107
    my $dformat = $self->{'dateformat'} or return undef;
100
40
95
    my $re = $self->regexp();
101
40
101
    my $xsub = $dmy_subs{$dformat};
102
40
50
98
    $debug and print STDERR "xsub: $xsub \n";
103
40
50
348
    if ( $val =~ /$re/ ) {
104
40
3181
        my $aref = eval $xsub;
105
40
100
172
        if ($dformat eq 'rfc822') {
106
2
4
            $aref = _abbr_to_numeric($aref, $dformat);
107
2
2
3
3
            pop(@{$aref}); #pop off tz offset because we are not setup to handle tz conversions just yet
108        }
109
40
88
        _check_date_and_time($aref);
110
40
40
51
93
        push @{$aref}, (-1,-1,1); # for some reason unknown to me, setting isdst to -1 or undef causes strftime to fail to return the tz offset which is required in RFC822 format -chris_n
111
40
40
86
285
        return @{$aref};
112    }
113
114    # $debug and
115
0
0
    carp "Illegal Date '$val' does not match '$dformat' format: " . $self->visual();
116
0
0
    return 0;
117}
118
119sub _abbr_to_numeric {
120
2
2
5
    my $aref = shift;
121
2
3
    my $dformat = shift;
122
2
50
7
    my ($month_abbr, $day_abbr) = ($aref->[4], $aref->[3]) if $dformat eq 'rfc822';
123
124    for( my $i = 0; $i < scalar(@months); $i++ ) {
125
19
100
69
        if ( $months[$i] =~ /$month_abbr/ ) {
126
2
3
            $aref->[4] = $i-1;
127
2
4
            last;
128        }
129
2
3
    };
130
131    for( my $i = 0; $i < scalar(@days); $i++ ) {
132
14
50
47
        if ( $days[$i] =~ /$day_abbr/ ) {
133
0
0
            $aref->[3] = $i;
134
0
0
            last;
135        }
136
2
2
    };
137
2
4
    return $aref;
138}
139
140sub _check_date_and_time {
141
40
40
81
    my $chron_ref = shift;
142
40
92
    my ( $year, $month, $day ) = _chron_to_ymd($chron_ref);
143
40
100
261
    unless ( check_date( $year, $month, $day ) ) {
144
9
388
        carp "Illegal date specified (year = $year, month = $month, day = $day)";
145    }
146
40
4902
    my ( $hour, $minute, $second ) = _chron_to_hms($chron_ref);
147
40
50
182
    unless ( check_time( $hour, $minute, $second ) ) {
148
0
0
        carp "Illegal time specified (hour = $hour, minute = $minute, second = $second)";
149    }
150}
151
152sub _chron_to_ymd {
153
40
40
63
    my $chron_ref = shift;
154
40
193
    return ( $chron_ref->[5] + 1900, $chron_ref->[4] + 1, $chron_ref->[3] );
155}
156
157sub _chron_to_hms {
158
40
40
65
    my $chron_ref = shift;
159
40
105
    return ( $chron_ref->[2], $chron_ref->[1], $chron_ref->[0] );
160}
161
162sub new {
163
78
78
344121
    my $this = shift;
164
78
33
451
    my $class = ref($this) || $this;
165
78
150
    my $self = {};
166
78
208
    bless $self, $class;
167
78
193
    return $self->init(@_);
168}
169
170sub init ($;$$) {
171
78
78
117
    my $self = shift;
172
78
100
    my $dformat;
173
78
100
287
    $self->{'dateformat'} = $dformat = ( scalar(@_) >= 2 ) ? $_[1] : _prefformat();
174
78
0
50
236
    ( $format_map{$dformat} ) or croak "Invalid date format '$dformat' from " . ( ( scalar(@_) >= 2 ) ? 'argument' : 'system preferences' );
175
78
100
675
    $self->{'dmy_arrayref'} = [ ( (@_) ? $self->dmy_map(shift) : localtime ) ];
176
78
0
0
50
33
339
0
0
    if ($debug && $debug > 1) { warn "(during init) \@\$self->{'dmy_arrayref'}: " . join( ' ', @{ $self->{'dmy_arrayref'} } ) . "\n"; }
177
78
441
    return $self;
178}
179
180sub output ($;$) {
181
207
207
64149
    my $self = shift;
182
207
100
1005
    my $newformat = (@_) ? _recognize_format(shift) : _prefformat();
183
207
207
207
50
482
438
14917
    return ( eval { POSIX::strftime( $posix_map{$newformat}, @{ $self->{'dmy_arrayref'} } ) } || undef );
184}
185
186sub today ($;$) { # NOTE: sets date value to today (and returns it in the requested or current format)
187
32
32
11031
    my $class = shift;
188
32
67
111
    $class = ref($class) || $class;
189
32
50
80
    my $format = (@_) ? _recognize_format(shift) : _prefformat();
190
32
76
    return $class->new()->output($format);
191}
192
193sub _recognize_format($) {
194
159
159
326
    my $incoming = shift;
195
159
100
475
    ( $incoming eq 'syspref' ) and return _prefformat();
196
155
50
2713
    ( scalar grep ( /^$incoming$/, keys %format_map ) == 1 ) or croak "The format you asked for ('$incoming') is unrecognized.";
197
155
1028
    return $incoming;
198}
199
200sub DHTMLcalendar ($;$) { # interface to posix_map
201
0
0
0
    my $class = shift;
202
0
0
0
    my $format = (@_) ? shift : _prefformat();
203
0
0
    return $posix_map{$format};
204}
205
206sub format { # get or set dateformat: iso, metric, us, etc.
207
6
6
17
    my $self = shift;
208
6
100
33
    (@_) or return $self->{'dateformat'};
209
5
9
    $self->{'dateformat'} = _recognize_format(shift);
210}
211
212sub visual {
213
5
5
35
    my $self = shift;
214
5
50
11
    if (@_) {
215
0
0
        return $format_map{ _recognize_format(shift) };
216    }
217
5
50
46
    $self eq __PACKAGE__ and return $format_map{ _prefformat() };
218
5
5
33
8
57
    return $format_map{ eval { $self->{'dateformat'} } || _prefformat() };
219}
220
221# like the functions from the old C4::Date.pm
222sub format_date {
223
8
50
8
3916
    return __PACKAGE__->new( shift, 'iso' )->output( (@_) ? shift : _prefformat() );
224}
225
226sub format_date_in_iso {
227
4
4
1668
    return __PACKAGE__->new( shift, _prefformat() )->output('iso');
228}
229
2301;