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
56
56
56
56
118287
426
2050
use strict;
19
56
56
56
56
596
427
2426
use warnings;
20
56
56
56
56
561
346
4717
use Carp;
21
56
56
56
56
1072
346
1013
use C4::Context;
22
56
56
56
56
461
246
5642
use C4::Debug;
23
56
56
56
56
441
317
2504
use Exporter;
24
56
56
56
56
480
208
1004
use POSIX qw(strftime);
25
56
56
56
56
140329
192141
8656
use Date::Calc qw(check_date check_time);
26
56
56
56
56
759
270
4520
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
27
56
56
56
56
415
247
3813
use vars qw($debug $cgi_debug);
28
29BEGIN {
30
56
56
257
    $VERSION = 0.04;
31
56
776
    @ISA = qw(Exporter);
32
56
1503
    @EXPORT_OK = qw(format_date_in_iso format_date);
33}
34
35
56
56
56
56
493
215
111984
use vars qw($prefformat);
36
37sub _prefformat {
38
286
50
286
730
    unless ( defined $prefformat ) {
39
0
0
        $prefformat = C4::Context->preference('dateformat');
40    }
41
286
865
    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
140
140
4421
    my $self = shift;
80
140
615
    my $delim = qr/:?\:|\/|-/; # "non memory" cluster: no backreference
81
140
100
33
618
    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
140
100
528
    ( $format eq 'sql' )
88      and return qr/^(\d{4})(\d{1,2})(\d{1,2})(?:\s{4}(\d{2})(\d{2})(\d{2}))?/;
89
124
100
913
    ( $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
76
100
278
    ( $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
68
779
    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
80
80
192
    my $self = shift;
98
80
50
313
    my $val = shift or return undef;
99
80
50
292
    my $dformat = $self->{'dateformat'} or return undef;
100
80
257
    my $re = $self->regexp();
101
80
222
    my $xsub = $dmy_subs{$dformat};
102
80
50
252
    $debug and print STDERR "xsub: $xsub \n";
103
80
50
809
    if ( $val =~ /$re/ ) {
104
80
6901
        my $aref = eval $xsub;
105
80
100
437
        if ($dformat eq 'rfc822') {
106
4
11
            $aref = _abbr_to_numeric($aref, $dformat);
107
4
4
4
7
            pop(@{$aref}); #pop off tz offset because we are not setup to handle tz conversions just yet
108        }
109
80
468
        _check_date_and_time($aref);
110
80
80
144
223
        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
80
80
146
1035
        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
4
4
5
    my $aref = shift;
121
4
8
    my $dformat = shift;
122
4
50
16
    my ($month_abbr, $day_abbr) = ($aref->[4], $aref->[3]) if $dformat eq 'rfc822';
123
124    for( my $i = 0; $i < scalar(@months); $i++ ) {
125
38
100
131
        if ( $months[$i] =~ /$month_abbr/ ) {
126
4
7
            $aref->[4] = $i-1;
127
4
6
            last;
128        }
129
4
6
    };
130
131    for( my $i = 0; $i < scalar(@days); $i++ ) {
132
28
50
92
        if ( $days[$i] =~ /$day_abbr/ ) {
133
0
0
            $aref->[3] = $i;
134
0
0
            last;
135        }
136
4
5
    };
137
4
9
    return $aref;
138}
139
140sub _check_date_and_time {
141
80
80
173
    my $chron_ref = shift;
142
80
215
    my ( $year, $month, $day ) = _chron_to_ymd($chron_ref);
143
80
100
600
    unless ( check_date( $year, $month, $day ) ) {
144
18
1156
        carp "Illegal date specified (year = $year, month = $month, day = $day)";
145    }
146
80
10971
    my ( $hour, $minute, $second ) = _chron_to_hms($chron_ref);
147
80
50
409
    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
80
80
266
    my $chron_ref = shift;
154
80
379
    return ( $chron_ref->[5] + 1900, $chron_ref->[4] + 1, $chron_ref->[3] );
155}
156
157sub _chron_to_hms {
158
80
80
207
    my $chron_ref = shift;
159
80
262
    return ( $chron_ref->[2], $chron_ref->[1], $chron_ref->[0] );
160}
161
162sub new {
163
156
156
744072
    my $this = shift;
164
156
33
1929
    my $class = ref($this) || $this;
165
156
371
    my $self = {};
166
156
674
    bless $self, $class;
167
156
469
    return $self->init(@_);
168}
169
170sub init ($;$$) {
171
156
156
286
    my $self = shift;
172
156
254
    my $dformat;
173
156
100
598
    $self->{'dateformat'} = $dformat = ( scalar(@_) >= 2 ) ? $_[1] : _prefformat();
174
156
0
50
527
    ( $format_map{$dformat} ) or croak "Invalid date format '$dformat' from " . ( ( scalar(@_) >= 2 ) ? 'argument' : 'system preferences' );
175
156
100
1429
    $self->{'dmy_arrayref'} = [ ( (@_) ? $self->dmy_map(shift) : localtime ) ];
176
156
0
0
50
33
740
0
0
    if ($debug && $debug > 1) { warn "(during init) \@\$self->{'dmy_arrayref'}: " . join( ' ', @{ $self->{'dmy_arrayref'} } ) . "\n"; }
177
156
1164
    return $self;
178}
179
180sub output ($;$) {
181
414
414
149059
    my $self = shift;
182
414
100
1294
    my $newformat = (@_) ? _recognize_format(shift) : _prefformat();
183
414
414
414
50
767
791
29592
    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
64
64
25667
    my $class = shift;
188
64
67
274
    $class = ref($class) || $class;
189
64
50
202
    my $format = (@_) ? _recognize_format(shift) : _prefformat();
190
64
184
    return $class->new()->output($format);
191}
192
193sub _recognize_format($) {
194
318
318
595
    my $incoming = shift;
195
318
100
849
    ( $incoming eq 'syspref' ) and return _prefformat();
196
310
50
5499
    ( scalar grep ( /^$incoming$/, keys %format_map ) == 1 ) or croak "The format you asked for ('$incoming') is unrecognized.";
197
310
1047
    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
12
12
29
    my $self = shift;
208
12
100
62
    (@_) or return $self->{'dateformat'};
209
10
22
    $self->{'dateformat'} = _recognize_format(shift);
210}
211
212sub visual {
213
10
10
34
    my $self = shift;
214
10
50
37
    if (@_) {
215
0
0
        return $format_map{ _recognize_format(shift) };
216    }
217
10
50
60
    $self eq __PACKAGE__ and return $format_map{ _prefformat() };
218
10
10
33
28
125
    return $format_map{ eval { $self->{'dateformat'} } || _prefformat() };
219}
220
221# like the functions from the old C4::Date.pm
222sub format_date {
223
16
50
16
8892
    return __PACKAGE__->new( shift, 'iso' )->output( (@_) ? shift : _prefformat() );
224}
225
226sub format_date_in_iso {
227
8
8
3930
    return __PACKAGE__->new( shift, _prefformat() )->output('iso');
228}
229
2301;