|
Lines 1-377
Link Here
|
| 1 |
package C4::Dates; |
|
|
| 2 |
|
| 3 |
# Copyright 2007 Liblime |
| 4 |
# Parts Copyright ACPL 2011 |
| 5 |
# Parts Copyright Catalyst IT 2012 |
| 6 |
# |
| 7 |
# This file is part of Koha. |
| 8 |
# |
| 9 |
# Koha is free software; you can redistribute it and/or modify it |
| 10 |
# under the terms of the GNU General Public License as published by |
| 11 |
# the Free Software Foundation; either version 3 of the License, or |
| 12 |
# (at your option) any later version. |
| 13 |
# |
| 14 |
# Koha is distributed in the hope that it will be useful, but |
| 15 |
# WITHOUT ANY WARRANTY; without even the implied warranty of |
| 16 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 17 |
# GNU General Public License for more details. |
| 18 |
# |
| 19 |
# You should have received a copy of the GNU General Public License |
| 20 |
# along with Koha; if not, see <http://www.gnu.org/licenses>. |
| 21 |
|
| 22 |
use strict; |
| 23 |
use warnings; |
| 24 |
use Carp; |
| 25 |
use C4::Context; |
| 26 |
use C4::Debug; |
| 27 |
use Exporter; |
| 28 |
use POSIX qw(strftime); |
| 29 |
use Date::Calc qw(check_date check_time); |
| 30 |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
| 31 |
use vars qw($debug $cgi_debug); |
| 32 |
|
| 33 |
BEGIN { |
| 34 |
$VERSION = 3.07.00.049; |
| 35 |
@ISA = qw(Exporter); |
| 36 |
@EXPORT_OK = qw(format_date_in_iso format_date); |
| 37 |
} |
| 38 |
|
| 39 |
use vars qw($prefformat); |
| 40 |
|
| 41 |
sub _prefformat { |
| 42 |
unless ( defined $prefformat ) { |
| 43 |
$prefformat = C4::Context->preference('dateformat'); |
| 44 |
} |
| 45 |
return $prefformat; |
| 46 |
} |
| 47 |
|
| 48 |
sub reset_prefformat { # subroutine to clear the prefformat, called when we change it |
| 49 |
if (defined $prefformat){ |
| 50 |
$prefformat = C4::Context->preference('dateformat'); |
| 51 |
} |
| 52 |
} |
| 53 |
|
| 54 |
our %format_map = ( |
| 55 |
iso => 'yyyy-mm-dd', # plus " HH:MM:SS" |
| 56 |
metric => 'dd/mm/yyyy', # plus " HH:MM:SS" |
| 57 |
us => 'mm/dd/yyyy', # plus " HH:MM:SS" |
| 58 |
sql => 'yyyymmdd HHMMSS', |
| 59 |
rfc822 => 'a, dd b y HH:MM:SS z ', |
| 60 |
); |
| 61 |
our %posix_map = ( |
| 62 |
iso => '%Y-%m-%d', # or %F, "Full Date" |
| 63 |
metric => '%d/%m/%Y', |
| 64 |
us => '%m/%d/%Y', |
| 65 |
sql => '%Y%m%d %H%M%S', |
| 66 |
rfc822 => '%a, %d %b %Y %H:%M:%S %z', |
| 67 |
); |
| 68 |
|
| 69 |
our %dmy_subs = ( # strings to eval (after using regular expression returned by regexp below) |
| 70 |
# make arrays for POSIX::strftime() |
| 71 |
iso => '[(($6||0),($5||0),($4||0),$3, $2 - 1, $1 - 1900)]', |
| 72 |
metric => '[(($6||0),($5||0),($4||0),$1, $2 - 1, $3 - 1900)]', |
| 73 |
us => '[(($6||0),($5||0),($4||0),$2, $1 - 1, $3 - 1900)]', |
| 74 |
sql => '[(($6||0),($5||0),($4||0),$3, $2 - 1, $1 - 1900)]', |
| 75 |
rfc822 => '[($7, $6, $5, $2, $3, $4 - 1900, $8)]', |
| 76 |
); |
| 77 |
|
| 78 |
our @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); |
| 79 |
|
| 80 |
our @days = qw(Sun Mon Tue Wed Thu Fri Sat); |
| 81 |
|
| 82 |
sub regexp ($;$) { |
| 83 |
my $self = shift; |
| 84 |
my $delim = qr/:?\:|\/|-/; # "non memory" cluster: no backreference |
| 85 |
my $format = (@_) ? _recognize_format(shift) : ( $self->{'dateformat'} || _prefformat() ); |
| 86 |
|
| 87 |
# Extra layer of checking $self->{'dateformat'}. |
| 88 |
# Why? Because it is assumed you might want to check regexp against an *instantiated* Dates object as a |
| 89 |
# way of saying "does this string match *whatever* format that Dates object is?" |
| 90 |
|
| 91 |
( $format eq 'sql' ) |
| 92 |
and return qr/^(\d{4})(\d{1,2})(\d{1,2})(?:\s{4}(\d{2})(\d{2})(\d{2}))?/; |
| 93 |
( $format eq 'iso' ) |
| 94 |
and return qr/^(\d{4})$delim(\d{1,2})$delim(\d{1,2})(?:(?:\s{1}|T)(\d{2})\:?(\d{2})\:?(\d{2}))?Z?/; |
| 95 |
( $format eq 'rfc822' ) |
| 96 |
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}))/; |
| 97 |
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 |
| 98 |
} |
| 99 |
|
| 100 |
sub dmy_map ($$) { |
| 101 |
my $self = shift; |
| 102 |
my $val = shift or return undef; |
| 103 |
my $dformat = $self->{'dateformat'} or return undef; |
| 104 |
my $re = $self->regexp(); |
| 105 |
my $xsub = $dmy_subs{$dformat}; |
| 106 |
$debug and print STDERR "xsub: $xsub \n"; |
| 107 |
if ( $val =~ /$re/ ) { |
| 108 |
my $aref = eval $xsub; |
| 109 |
if ($dformat eq 'rfc822') { |
| 110 |
$aref = _abbr_to_numeric($aref, $dformat); |
| 111 |
pop(@{$aref}); #pop off tz offset because we are not setup to handle tz conversions just yet |
| 112 |
} |
| 113 |
_check_date_and_time($aref); |
| 114 |
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 |
| 115 |
return @{$aref}; |
| 116 |
} |
| 117 |
|
| 118 |
# $debug and |
| 119 |
carp "Illegal Date '$val' does not match '$dformat' format: " . $self->visual(); |
| 120 |
return 0; |
| 121 |
} |
| 122 |
|
| 123 |
sub _abbr_to_numeric { |
| 124 |
my $aref = shift; |
| 125 |
my $dformat = shift; |
| 126 |
my ($month_abbr, $day_abbr) = ($aref->[4], $aref->[3]) if $dformat eq 'rfc822'; |
| 127 |
|
| 128 |
for( my $i = 0; $i < scalar(@months); $i++ ) { |
| 129 |
if ( $months[$i] =~ /$month_abbr/ ) { |
| 130 |
$aref->[4] = $i-1; |
| 131 |
last; |
| 132 |
} |
| 133 |
}; |
| 134 |
|
| 135 |
for( my $i = 0; $i < scalar(@days); $i++ ) { |
| 136 |
if ( $days[$i] =~ /$day_abbr/ ) { |
| 137 |
$aref->[3] = $i; |
| 138 |
last; |
| 139 |
} |
| 140 |
}; |
| 141 |
return $aref; |
| 142 |
} |
| 143 |
|
| 144 |
sub _check_date_and_time { |
| 145 |
my $chron_ref = shift; |
| 146 |
my ( $year, $month, $day ) = _chron_to_ymd($chron_ref); |
| 147 |
unless ( check_date( $year, $month, $day ) ) { |
| 148 |
carp "Illegal date specified (year = $year, month = $month, day = $day)"; |
| 149 |
} |
| 150 |
my ( $hour, $minute, $second ) = _chron_to_hms($chron_ref); |
| 151 |
unless ( check_time( $hour, $minute, $second ) ) { |
| 152 |
carp "Illegal time specified (hour = $hour, minute = $minute, second = $second)"; |
| 153 |
} |
| 154 |
} |
| 155 |
|
| 156 |
sub _chron_to_ymd { |
| 157 |
my $chron_ref = shift; |
| 158 |
return ( $chron_ref->[5] + 1900, $chron_ref->[4] + 1, $chron_ref->[3] ); |
| 159 |
} |
| 160 |
|
| 161 |
sub _chron_to_hms { |
| 162 |
my $chron_ref = shift; |
| 163 |
return ( $chron_ref->[2], $chron_ref->[1], $chron_ref->[0] ); |
| 164 |
} |
| 165 |
|
| 166 |
sub new { |
| 167 |
my $this = shift; |
| 168 |
my $class = ref($this) || $this; |
| 169 |
my $self = {}; |
| 170 |
bless $self, $class; |
| 171 |
return $self->init(@_); |
| 172 |
} |
| 173 |
|
| 174 |
sub init ($;$$) { |
| 175 |
my $self = shift; |
| 176 |
my $dformat; |
| 177 |
$self->{'dateformat'} = $dformat = ( scalar(@_) >= 2 ) ? $_[1] : _prefformat(); |
| 178 |
( $format_map{$dformat} ) or croak "Invalid date format '$dformat' from " . ( ( scalar(@_) >= 2 ) ? 'argument' : 'system preferences' ); |
| 179 |
$self->{'dmy_arrayref'} = [ ( (@_) ? $self->dmy_map(shift) : localtime ) ]; |
| 180 |
if ($debug && $debug > 1) { warn "(during init) \@\$self->{'dmy_arrayref'}: " . join( ' ', @{ $self->{'dmy_arrayref'} } ) . "\n"; } |
| 181 |
return $self; |
| 182 |
} |
| 183 |
|
| 184 |
sub output ($;$) { |
| 185 |
my $self = shift; |
| 186 |
my $newformat = (@_) ? _recognize_format(shift) : _prefformat(); |
| 187 |
return ( eval { POSIX::strftime( $posix_map{$newformat}, @{ $self->{'dmy_arrayref'} } ) } || undef ); |
| 188 |
} |
| 189 |
|
| 190 |
sub today ($;$) { # NOTE: sets date value to today (and returns it in the requested or current format) |
| 191 |
my $class = shift; |
| 192 |
$class = ref($class) || $class; |
| 193 |
my $format = (@_) ? _recognize_format(shift) : _prefformat(); |
| 194 |
return $class->new()->output($format); |
| 195 |
} |
| 196 |
|
| 197 |
sub _recognize_format($) { |
| 198 |
my $incoming = shift; |
| 199 |
( $incoming eq 'syspref' ) and return _prefformat(); |
| 200 |
( scalar grep ( /^$incoming$/, keys %format_map ) == 1 ) or croak "The format you asked for ('$incoming') is unrecognized."; |
| 201 |
return $incoming; |
| 202 |
} |
| 203 |
|
| 204 |
sub DHTMLcalendar ($;$) { # interface to posix_map |
| 205 |
my $class = shift; |
| 206 |
my $format = (@_) ? shift : _prefformat(); |
| 207 |
return $posix_map{$format}; |
| 208 |
} |
| 209 |
|
| 210 |
sub format { # get or set dateformat: iso, metric, us, etc. |
| 211 |
my $self = shift; |
| 212 |
(@_) or return $self->{'dateformat'}; |
| 213 |
$self->{'dateformat'} = _recognize_format(shift); |
| 214 |
} |
| 215 |
|
| 216 |
sub visual { |
| 217 |
my $self = shift; |
| 218 |
if (@_) { |
| 219 |
return $format_map{ _recognize_format(shift) }; |
| 220 |
} |
| 221 |
$self eq __PACKAGE__ and return $format_map{ _prefformat() }; |
| 222 |
return $format_map{ eval { $self->{'dateformat'} } || _prefformat() }; |
| 223 |
} |
| 224 |
|
| 225 |
# like the functions from the old C4::Date.pm |
| 226 |
sub format_date { |
| 227 |
return __PACKAGE__->new( shift, 'iso' )->output( (@_) ? shift : _prefformat() ); |
| 228 |
} |
| 229 |
|
| 230 |
sub format_date_in_iso { |
| 231 |
return __PACKAGE__->new( shift, _prefformat() )->output('iso'); |
| 232 |
} |
| 233 |
|
| 234 |
1; |
| 235 |
__END__ |
| 236 |
|
| 237 |
=head1 C4::Dates.pm - a more object-oriented replacement for Date.pm. |
| 238 |
|
| 239 |
The core problem to address is the multiplicity of formats used by different Koha |
| 240 |
installations around the world. We needed to move away from any hard-coded values at |
| 241 |
the script level, for example in initial form values or checks for min/max date. The |
| 242 |
reason is clear when you consider string '07/01/2004'. Depending on the format, it |
| 243 |
represents July 1st (us), or January 7th (metric), or an invalid value (iso). |
| 244 |
|
| 245 |
The formats supported by Koha are: |
| 246 |
iso - ISO 8601 (extended) |
| 247 |
us - U.S. standard |
| 248 |
metric - European standard (slight misnomer, not really decimalized metric) |
| 249 |
sql - log format, not really for human consumption |
| 250 |
rfc822 - Standard for using with RSS feeds, etc. |
| 251 |
|
| 252 |
=head2 ->new([string_date,][date_format]) |
| 253 |
|
| 254 |
Arguments to new() are optional. If string_date is not supplied, the present system date is |
| 255 |
used. If date_format is not supplied, the system preference from C4::Context is used. |
| 256 |
|
| 257 |
Examples: |
| 258 |
|
| 259 |
my $now = C4::Dates->new(); |
| 260 |
my $date1 = C4::Dates->new("09-21-1989","us"); |
| 261 |
my $date2 = C4::Dates->new("19890921 143907","sql"); |
| 262 |
|
| 263 |
=head2 ->output([date_format]) |
| 264 |
|
| 265 |
The date value is stored independent of any specific format. Therefore any format can be |
| 266 |
invoked when displaying it. |
| 267 |
|
| 268 |
my $date = C4::Dates->new(); # say today is July 12th, 2010 |
| 269 |
print $date->output("iso"); # prints "2010-07-12" |
| 270 |
print "\n"; |
| 271 |
print $date->output("metric"); # prints "12-07-2010" |
| 272 |
|
| 273 |
However, it is still necessary to know the format of any incoming date value (e.g., |
| 274 |
setting the value of an object with new()). Like new(), output() assumes the system preference |
| 275 |
date format unless otherwise instructed. |
| 276 |
|
| 277 |
=head2 ->format([date_format]) |
| 278 |
|
| 279 |
With no argument, format returns the object's current date_format. Otherwise it attempts to |
| 280 |
set the object format to the supplied value. |
| 281 |
|
| 282 |
Some previously desirable functions are now unnecessary. For example, you might want a |
| 283 |
method/function to tell you whether or not a Dates.pm object is of the 'iso' type. But you |
| 284 |
can see by this example that such a test is trivial to accomplish, and not necessary to |
| 285 |
include in the module: |
| 286 |
|
| 287 |
sub is_iso { |
| 288 |
my $self = shift; |
| 289 |
return ($self->format() eq "iso"); |
| 290 |
} |
| 291 |
|
| 292 |
Note: A similar function would need to be included for each format. |
| 293 |
|
| 294 |
Instead a dependent script can retrieve the format of the object directly and decide what to |
| 295 |
do with it from there: |
| 296 |
|
| 297 |
my $date = C4::Dates->new(); |
| 298 |
my $format = $date->format(); |
| 299 |
($format eq "iso") or do_something($date); |
| 300 |
|
| 301 |
Or if you just want to print a given value and format, no problem: |
| 302 |
|
| 303 |
my $date = C4::Dates->new("1989-09-21", "iso"); |
| 304 |
print $date->output; |
| 305 |
|
| 306 |
Alternatively: |
| 307 |
|
| 308 |
print C4::Dates->new("1989-09-21", "iso")->output; |
| 309 |
|
| 310 |
Or even: |
| 311 |
|
| 312 |
print C4::Dates->new("21-09-1989", "metric")->output("iso"); |
| 313 |
|
| 314 |
=head2 "syspref" -- System Preference(s) |
| 315 |
|
| 316 |
Perhaps you want to force data obtained in a known format to display according to the user's system |
| 317 |
preference, without necessarily knowing what that preference is. For this purpose, you can use the |
| 318 |
pseudo-format argument "syspref". |
| 319 |
|
| 320 |
For example, to print an ISO date (from the database) in the <systempreference> format: |
| 321 |
|
| 322 |
my $date = C4::Dates->new($date_from_database,"iso"); |
| 323 |
my $datestring_for_display = $date->output("syspref"); |
| 324 |
print $datestring_for_display; |
| 325 |
|
| 326 |
Or even: |
| 327 |
|
| 328 |
print C4::Dates->new($date_from_database,"iso")->output("syspref"); |
| 329 |
|
| 330 |
If you just want to know what the <systempreferece> is, a default Dates object can tell you: |
| 331 |
|
| 332 |
C4::Dates->new()->format(); |
| 333 |
|
| 334 |
=head2 ->DHMTLcalendar([date_format]) |
| 335 |
|
| 336 |
Returns the format string for DHTML Calendar Display based on date_format. |
| 337 |
If date_format is not supplied, the return is based on system preference. |
| 338 |
|
| 339 |
C4::Dates->DHTMLcalendar(); # e.g., returns "%m/%d/%Y" for 'us' system preference |
| 340 |
|
| 341 |
=head3 Error Handling |
| 342 |
|
| 343 |
Some error handling is provided in this module, but not all. Requesting an unknown format is a |
| 344 |
fatal error (because it is programmer error, not user error, typically). |
| 345 |
|
| 346 |
Scripts must still perform validation of user input. Attempting to set an invalid value will |
| 347 |
return 0 or undefined, so a script might check as follows: |
| 348 |
|
| 349 |
my $date = C4::Dates->new($input) or deal_with_it("$input didn't work"); |
| 350 |
|
| 351 |
To validate before creating a new object, use the regexp method of the class: |
| 352 |
|
| 353 |
$input =~ C4::Dates->regexp("iso") or deal_with_it("input ($input) invalid as iso format"); |
| 354 |
my $date = C4::Dates->new($input,"iso"); |
| 355 |
|
| 356 |
More verbose debugging messages are sent in the presence of non-zero $ENV{"DEBUG"}. |
| 357 |
|
| 358 |
Notes: if the date in the db is null or empty, interpret null expiration to mean "never expires". |
| 359 |
|
| 360 |
=head3 _prefformat() |
| 361 |
|
| 362 |
This internal function is used to read the preferred date format |
| 363 |
from the system preference table. It reads the preference once, |
| 364 |
then caches it. |
| 365 |
|
| 366 |
This replaces using the package variable $prefformat directly, and |
| 367 |
specifically, doing a call to C4::Context->preference() during |
| 368 |
module initialization. That way, C4::Dates no longer has a |
| 369 |
compile-time dependency on having a valid $dbh. |
| 370 |
|
| 371 |
=head3 TO DO |
| 372 |
|
| 373 |
If the date format is not in <systempreference>, we should send an error back to the user. |
| 374 |
This kind of check should be centralized somewhere. Probably not here, though. |
| 375 |
|
| 376 |
=cut |
| 377 |
|
| 378 |
- |