1129 lines
36 KiB
Perl
1129 lines
36 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Date
|
|
# Author : Aki Mimoto
|
|
# CVS Info :
|
|
# $Id: Date.pm,v 1.75 2005/04/04 22:21:23 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Generic date manipulation routines. Exports functions to use.
|
|
#
|
|
|
|
package GT::Date;
|
|
# ===============================================================
|
|
# This package implements the date handling routines.
|
|
# The default date format is yyyy-mm-dd as in 1999-12-25. To change the
|
|
# format, edit $DATE_FMT and use any of the following:
|
|
#
|
|
# yyyy - four digit year as in 1999
|
|
# yy - two digit year as in 99
|
|
# y - two digit year without leading 0
|
|
# mmmm - long month name as in January
|
|
# mmm - short month name as in Jan
|
|
# mm - numerical month name as in 01
|
|
# m - same as mm, but without leading 0's for months 1-9
|
|
# dddd - long day name as in Sunday
|
|
# ddd - short day name as in Sun
|
|
# dd - numerical date
|
|
# d - numerical date without leading 0
|
|
# HH - numerical hours (24 hour time)
|
|
# H - numerical hours without leading 0 (24 hour time)
|
|
# hh - numerical hours (12 hour time)
|
|
# h - numerical hours without leading 0 (12 hour time)
|
|
# MM - numerical minutes
|
|
# M - numerical minutes without leading 0
|
|
# ss - numerical seconds
|
|
# s - numerical seconds without leading 0
|
|
# tt - AM or PM (use with 12 hour time)
|
|
# o - + or - gm offset
|
|
#
|
|
# Common formats:
|
|
# %yyyy%-%mm%-%dd% 1999-12-25
|
|
# %dd%-%mmm%-%yyyy% 12-Dec-1999
|
|
# %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999
|
|
# %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999
|
|
#
|
|
# RFC822
|
|
# %ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o% Sat, 12, Dec 1999 21:32:02 -0800
|
|
#
|
|
# MySQL
|
|
# %yyyy%-%mm%-%dd% %HH%:%MM%:%ss% 1999-03-25 21:32:02
|
|
#
|
|
|
|
use strict;
|
|
use vars qw/$GM_OFFSET $GM_OFFSET_DST @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DATE_FMT $RANGE_CHECK
|
|
$VERSION $AUTOLOAD $LANGUAGE $OFFSET %GMTTIME $LOUD/;
|
|
use GT::Cache;
|
|
use Exporter;
|
|
use GT::AutoLoader;
|
|
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.75 $ =~ /(\d+)\.(\d+)/;
|
|
@ISA = qw/Exporter/;
|
|
@EXPORT_OK = qw/timelocal timegm date_is_valid date_is_greater date_is_smaller date_get date_get_gm date_gmt_offset
|
|
date_comp date_diff date_add date_add_gm date_sub date_sub_gm date_http_gmt
|
|
date_set_month date_set_month_short date_set_days date_set_days_short
|
|
date_set_format date_get_format date_transform parse_format format_date
|
|
/;
|
|
%EXPORT_TAGS = ( all => \@EXPORT_OK, timelocal => [ qw(timelocal timegm) ] );
|
|
|
|
# Module Options.
|
|
$DATE_FMT = "%yyyy%-%mm%-%dd%";
|
|
$OFFSET = 0 * 3600;
|
|
$RANGE_CHECK = 0;
|
|
$LOUD = 0;
|
|
$LANGUAGE = {
|
|
'month_names' => [qw/January February March April May June July August September October November December/],
|
|
'day_names' => [qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/],
|
|
'short_month_names' => [qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/],
|
|
'short_day_names' => [qw/Sun Mon Tue Wed Thu Fri Sat/]
|
|
};
|
|
|
|
# Time strings to GM offset in minutes
|
|
%GMTTIME = (
|
|
GMT => 0,
|
|
UT => 0,
|
|
BST => 60,
|
|
IST => 60,
|
|
WET => 0,
|
|
WEST => 60,
|
|
CET => 60,
|
|
CEST => 120,
|
|
EET => 120,
|
|
EEST => 180,
|
|
MSK => 180,
|
|
MSD => 240,
|
|
AST => -240,
|
|
ADT => -180,
|
|
EST => -300,
|
|
EDT => -240,
|
|
ET => -300,
|
|
CST => -360,
|
|
CDT => -300,
|
|
CT => -360,
|
|
MST => -420,
|
|
MDT => -360,
|
|
MT => -420,
|
|
PST => -480,
|
|
PDT => -420,
|
|
PT => -480,
|
|
HST => -600,
|
|
AKST => -540,
|
|
AKDT => -480,
|
|
WST => 480,
|
|
);
|
|
|
|
# Set up our Cache objects.
|
|
use vars qw(
|
|
@MONTHS %MONTHS @DAYS %DAYS @MONTHS_SH %MONTHS_SH @DAYS_SH %DAYS_SH %MONTH_HASH
|
|
%DATE_TO_TM %DATE_TRANS %MONTH_YEAR
|
|
);
|
|
|
|
tie %DATE_TO_TM, 'GT::Cache', 500, \&_date_str_to_time;
|
|
tie %DATE_TRANS, 'GT::Cache', 500, \&_transform;
|
|
tie %MONTH_YEAR, 'GT::Cache', 500, \&_calc_my;
|
|
|
|
# Constants in calculating the time array => unix time.
|
|
use constants
|
|
SEC => 1,
|
|
MIN => 60, # 60 * SEC
|
|
HOUR => 3600, # 60 * MIN
|
|
DAY => 86400; # 24 * HOUR
|
|
|
|
build_lang();
|
|
|
|
sub build_lang {
|
|
# ----------------------------------------------------
|
|
# Build vars to use internally.
|
|
#
|
|
@MONTHS = @{$LANGUAGE->{month_names}}; my $i = 0;
|
|
%MONTHS = map { $_ => $i++ } @MONTHS;
|
|
@DAYS = @{$LANGUAGE->{day_names}}; $i = 0;
|
|
%DAYS = map { $_ => $i++ } @DAYS;
|
|
@MONTHS_SH = @{$LANGUAGE->{short_month_names}}; $i = 0;
|
|
%MONTHS_SH = map { $_ => $i++ } @MONTHS_SH;
|
|
@DAYS_SH = @{$LANGUAGE->{short_day_names}}; $i = 0;
|
|
%DAYS_SH = map { $_ => $i++ } @DAYS_SH;
|
|
%MONTH_HASH = map { ( $MONTHS[$_] => $_, $MONTHS_SH[$_] => $_ ) } ( 0..11 );
|
|
}
|
|
|
|
$COMPILE{date_set_format} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_set_format {
|
|
# ----------------------------------------------------
|
|
# Set the date format to use, make sure to clear caches.
|
|
#
|
|
$DATE_FMT = shift;
|
|
%DATE_TO_TM = ();
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_get_format} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_get_format {
|
|
# ----------------------------------------------------
|
|
# Set the date format to use.
|
|
#
|
|
return $DATE_FMT;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_set_month} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_set_month {
|
|
# ----------------------------------------------------
|
|
# Set the language.
|
|
#
|
|
my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
|
|
$LANGUAGE->{month_names} = $lang;
|
|
build_lang();
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_set_month_short} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_set_month_short {
|
|
# ----------------------------------------------------
|
|
# Set the language.
|
|
#
|
|
my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
|
|
$LANGUAGE->{short_month_names} = $lang;
|
|
build_lang();
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_set_days} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_set_days {
|
|
# ----------------------------------------------------
|
|
# Set the language.
|
|
#
|
|
my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
|
|
$LANGUAGE->{day_names} = $lang;
|
|
build_lang();
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_set_days_short} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_set_days_short {
|
|
# ----------------------------------------------------
|
|
# Set the language.
|
|
#
|
|
my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
|
|
$LANGUAGE->{short_day_names} = $lang;
|
|
build_lang();
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_is_valid} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_is_valid {
|
|
# ----------------------------------------------------
|
|
# Check whether a string is a valid date.
|
|
#
|
|
my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
return $DATE_TO_TM{$key};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_is_greater} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_is_greater {
|
|
# ----------------------------------------------------
|
|
# Returns 1 if the first date is larger then the second.
|
|
#
|
|
(date_comp(@_) == 1) ? return 1 : return undef;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_is_smaller} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_is_smaller {
|
|
# ----------------------------------------------------
|
|
# Returns 1 if the first date is smaller then the second.
|
|
#
|
|
(date_comp(@_) == -1) ? return 1 : return undef;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_get} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_get {
|
|
# ----------------------------------------------------
|
|
# Return today's date or a date from a time() that you
|
|
# pass in. Optionally takes a second argument as a
|
|
# date format to return the result in. Any offset will
|
|
# be added to the date as required.
|
|
#
|
|
my $time = shift || time;
|
|
$time += $OFFSET if $OFFSET;
|
|
my $fmt = shift || $DATE_FMT;
|
|
my @date = localtime($time);
|
|
return format_date(\@date, $fmt);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_get_gm} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_get_gm {
|
|
# ----------------------------------------------------
|
|
# Return today's date or a date from a time() that you
|
|
# pass in. Optionally takes a second argument as a
|
|
# date format to return the result in.
|
|
#
|
|
my $time = shift || time;
|
|
my $fmt = shift || $DATE_FMT;
|
|
my @date = gmtime($time);
|
|
return format_date(\@date, $fmt);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_comp} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_comp {
|
|
# ----------------------------------------------------
|
|
# Equivalant to $date1 <=> $date2
|
|
#
|
|
my $key1 = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
my $key2 = join("\0", $_[1], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
return $DATE_TO_TM{$key1} <=> $DATE_TO_TM{$key2};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_diff} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_diff {
|
|
# ----------------------------------------------------
|
|
# Return number of days difference between two dates.
|
|
#
|
|
my $key1 = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
my $key2 = join("\0", $_[1], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
return int (($DATE_TO_TM{$key1} - $DATE_TO_TM{$key2}) / DAY);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_add} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_add {
|
|
# ----------------------------------------------------
|
|
# Returns argument a +- x days.
|
|
#
|
|
my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
my @date = localtime($DATE_TO_TM{$key} + $_[1] * DAY);
|
|
return format_date(\@date);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_add_gm} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_add_gm {
|
|
# ----------------------------------------------------
|
|
# Returns argument a +- x days.
|
|
#
|
|
my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
my @date = gmtime($DATE_TO_TM{$key} + $_[1] * DAY);
|
|
return format_date(\@date);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_sub} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_sub {
|
|
# ----------------------------------------------------
|
|
# Returns argument - days.
|
|
#
|
|
my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
my @date = localtime($DATE_TO_TM{$key} - $_[1] * DAY);
|
|
return format_date(\@date);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_sub_gm} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_sub_gm {
|
|
# ----------------------------------------------------
|
|
# Returns argument - days.
|
|
#
|
|
my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
my @date = gmtime($DATE_TO_TM{$key} - $_[1] * DAY);
|
|
return format_date(\@date);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_transform} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_transform {
|
|
# ----------------------------------------------------
|
|
# Takes a date, followed by orig format and transforms to
|
|
# a new format.
|
|
#
|
|
my ($date, $orig, $new) = @_;
|
|
my $key = join("\0", $date, $orig, $new, @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH);
|
|
return $DATE_TRANS{$key};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{format_date} = __LINE__ . <<'END_OF_SUB';
|
|
sub format_date {
|
|
# ----------------------------------------------------
|
|
# Takes an array from localtime or equiv and a date format
|
|
# and returns date.
|
|
#
|
|
my $date = shift;
|
|
my $fmt = shift || $DATE_FMT;
|
|
my (@real, $time);
|
|
|
|
# Make sure we have all the info.
|
|
for (0 .. $#{$date}) {
|
|
if (! defined $date->[$_]) {
|
|
if (!@real) {
|
|
$time = timelocal(@{$date});
|
|
@real = localtime($time);
|
|
}
|
|
$date->[$_] = $real[$_];
|
|
}
|
|
}
|
|
my ($sec, $min, $hour, $day, $mon, $year, $dwk) = @{$date};
|
|
my $twelve_hour = $hour == 0 ? 12 : $hour > 12 ? $hour - 12 : $hour;
|
|
my $vals = {
|
|
ss => sprintf ("%02d", $sec),
|
|
s => $sec,
|
|
MM => sprintf ("%02d", $min),
|
|
M => $min,
|
|
HH => sprintf ("%02d", $hour),
|
|
H => $hour,
|
|
hh => sprintf ("%02d", $twelve_hour),
|
|
h => $twelve_hour,
|
|
tt => ($hour >= 12 ? "PM" : "AM"),
|
|
dd => sprintf ("%02d", $day),
|
|
d => $day,
|
|
mm => sprintf ("%02d", $mon + 1),
|
|
m => $mon + 1,
|
|
mmmm => defined $MONTHS[$mon] ? $MONTHS[$mon] : '',
|
|
mmm => defined $MONTHS_SH[$mon] ? $MONTHS_SH[$mon] : '',
|
|
dddd => defined $DAYS[$dwk] ? $DAYS[$dwk] : '',
|
|
ddd => defined $DAYS_SH[$dwk] ? $DAYS_SH[$dwk] : '',
|
|
yyyy => $year + 1900,
|
|
yy => sprintf ("%02d", $year % 100),
|
|
y => $year % 100,
|
|
o => sub {
|
|
my $offset = date_gmt_offset();
|
|
return sprintf ("%+05d", int($offset / 3600) * 100 + int(($offset % 3600) /60))
|
|
}
|
|
|
|
};
|
|
$fmt =~ s/%([^%]+)%/exists $vals->{$1} ? (ref($vals->{$1}) eq 'CODE') ? $vals->{$1}->() : $vals->{$1} : ''/eg;
|
|
return $fmt;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{parse_format} = __LINE__ . <<'END_OF_SUB';
|
|
sub parse_format {
|
|
# ----------------------------------------------------
|
|
# Takes a string and a date format and returns an array
|
|
# ref of the first 7 arguments returned by localtime().
|
|
#
|
|
my $date = shift;
|
|
my $fmt = shift || $DATE_FMT;
|
|
return unless ($date);
|
|
|
|
my $pos = 0;
|
|
my ($sec, $min, $hour, $pm, $day, $mon, $year, $dwk, $before, $type, $adjust, $leading, $h24);
|
|
while ($fmt =~ /([^%]*?)%([^%]+)%/g) {
|
|
$leading = $1;
|
|
$type = $2;
|
|
CASE: {
|
|
# yyyy - four digit year as in 1999
|
|
($type eq 'yyyy' and !defined $year)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{4})// or return;
|
|
$year = int( int( $1 ) - 1900);
|
|
last CASE;
|
|
};
|
|
# yy - two digit year as in 99
|
|
($type eq 'yy' and !defined $year)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{2})// or return;
|
|
$year = int $1;
|
|
if ( $year < 69 ) { # 20xx
|
|
$year += 2000;
|
|
}
|
|
else { # 19xx
|
|
$year += 1900;
|
|
}
|
|
$year = $year - 1900;
|
|
last CASE;
|
|
};
|
|
# y - two digit year without leading 0
|
|
($type eq 'y' and !defined $year)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d?\d)// or return;
|
|
$year = int $1;
|
|
$year = 2000 + $year if $year < 40;
|
|
$year = $year - 1900;
|
|
last CASE;
|
|
};
|
|
# mmmm - long month name as in January
|
|
($type eq 'mmmm' and !defined $mon)
|
|
and do {
|
|
my $val;
|
|
for ( keys %MONTHS ) {
|
|
if ( index( $date, "$leading$_" ) == 0 ) {
|
|
$val = $_;
|
|
substr( $date, 0, length( $leading.$_ ) ) = '';
|
|
last;
|
|
}
|
|
}
|
|
$val or return;
|
|
$mon = int $MONTHS{$val};
|
|
last CASE;
|
|
};
|
|
# mmm - short month name as in Jan
|
|
($type eq 'mmm' and !defined $mon)
|
|
and do {
|
|
my $val;
|
|
for ( keys %MONTHS_SH ) {
|
|
if ( index( $date, "$leading$_" ) == 0 ) {
|
|
$val = $_;
|
|
substr( $date, 0, length( $leading.$_ ) ) = '';
|
|
last;
|
|
}
|
|
}
|
|
$val or return;
|
|
$mon = int $MONTHS_SH{$val};
|
|
last CASE;
|
|
};
|
|
# mm - numerical month name as in 01
|
|
($type eq 'mm' and !defined $mon)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{2})// or return;
|
|
$mon = int( $1 - 1 );
|
|
last CASE;
|
|
};
|
|
# m - same as mm, but without leading 0's for months 1-9
|
|
($type eq 'm' and !defined $mon)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d?\d)// or return;
|
|
$mon = int( $1 - 1 );
|
|
last CASE;
|
|
};
|
|
# dddd - long day name as in Sunday
|
|
($type eq 'dddd' and !defined $dwk)
|
|
and do {
|
|
my $val;
|
|
for ( keys %DAYS ) {
|
|
if ( index( $date, "$leading$_" ) == 0 ) {
|
|
$val = $_;
|
|
substr( $date, 0, length( $leading.$_ ) ) = '';
|
|
last;
|
|
}
|
|
}
|
|
$val or return;
|
|
$dwk = int $DAYS{$val};
|
|
last CASE;
|
|
};
|
|
# ddd - short day name as in Sun
|
|
($type eq 'ddd' and !defined $dwk)
|
|
and do {
|
|
my $val;
|
|
for ( keys %DAYS_SH ) {
|
|
if ( index( $date, "$leading$_" ) == 0 ) {
|
|
$val = $_;
|
|
substr( $date, 0, length( $leading.$_ ) ) = '';
|
|
last;
|
|
}
|
|
}
|
|
$val or return;
|
|
$dwk = int $DAYS_SH{$val};
|
|
last CASE;
|
|
};
|
|
# dd - numerical date
|
|
($type eq 'dd' and !defined $day)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{2})// or return;
|
|
$day = int $1;
|
|
last CASE;
|
|
};
|
|
# d - numerical date without leading 0
|
|
($type eq 'd' and !defined $day)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d?\d)// or return;
|
|
$day = int $1;
|
|
last CASE;
|
|
};
|
|
# HH - numerical hours (24 hour time)
|
|
($type eq 'HH' and !defined $hour)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{2})// or return;
|
|
$hour = int $1;
|
|
$h24 = 1;
|
|
last CASE;
|
|
};
|
|
# H - numerical hours without leading 0 (24 hour time)
|
|
($type eq 'H' and !defined $hour)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d?\d)// or return;
|
|
$hour = int $1;
|
|
$h24 = 1;
|
|
last CASE;
|
|
};
|
|
# hh - numerical hours (12 hour time)
|
|
($type eq 'hh' and !defined $hour)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{2})// or return;
|
|
$hour = int $1;
|
|
last CASE;
|
|
};
|
|
# h - numerical hours without leading 0 (12 hour time)
|
|
($type eq 'h' and !defined $hour)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d?\d)// or return;
|
|
$hour = int $1;
|
|
last CASE;
|
|
};
|
|
# MM - numerical minutes
|
|
($type eq 'MM' and !defined $min)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{2})// or return;
|
|
$min = int $1;
|
|
last CASE;
|
|
};
|
|
# M - numerical minutes without leading 0
|
|
($type eq 'M' and !defined $min)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d?\d)// or return;
|
|
$min = int $1;
|
|
last CASE;
|
|
};
|
|
# ss - numerical seconds
|
|
($type eq 'ss' and !defined $sec)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d{2})// or return;
|
|
$sec = int $1;
|
|
last CASE;
|
|
};
|
|
# s - numerical seconds without leading 0
|
|
($type eq 's' and !defined $sec)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E(\d?\d)// or return;
|
|
$sec = int $1;
|
|
last CASE;
|
|
};
|
|
# tt - AM or PM (use with 12 hour time)
|
|
($type eq 'tt' and !defined $pm)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E([aApP][mM])// or return;
|
|
$pm = uc( $1 ) eq 'PM';
|
|
last CASE;
|
|
};
|
|
# o - + or - gm offset
|
|
($type eq 'o' and !defined $adjust)
|
|
and do {
|
|
$date =~ s/^\Q$leading\E((?:\w{1,4})|(?:[+\-]?\d{3,4}))// or return;
|
|
$adjust = $1;
|
|
last CASE;
|
|
};
|
|
return;
|
|
}
|
|
}
|
|
defined $day or ($day = 1);
|
|
defined $mon or ($mon = 0);
|
|
defined $sec or ($sec = 0);
|
|
defined $min or ($min = 0);
|
|
defined $hour or ($hour = 0);
|
|
if ($pm and $hour < 12) {
|
|
$hour += 12;
|
|
}
|
|
elsif (!$pm and !$h24 and $hour == 12) {
|
|
$hour = 0;
|
|
}
|
|
if (defined $day && defined $mon && defined $year) {
|
|
if (defined $adjust) {
|
|
my $minutes;
|
|
|
|
if ($adjust =~ /^([+\-]?)(\d?\d)(\d\d)$/) {
|
|
my $neg = $1 || '+';
|
|
if ($neg eq '-') {
|
|
$minutes -= ($2 * 60) + $3;
|
|
}
|
|
else {
|
|
$minutes = ($2 * 60) + $3;
|
|
}
|
|
}
|
|
elsif (exists $GMTTIME{$adjust}) {
|
|
$minutes = $GMTTIME{$adjust};
|
|
}
|
|
if (defined $minutes) {
|
|
my $time = timelocal($sec, $min, $hour, $day, $mon, $year, $dwk);
|
|
my $gm_offset = date_gmt_offset();
|
|
my $tm_offset = $minutes * 60;
|
|
$time = $time + ($gm_offset - $tm_offset);
|
|
|
|
return [(localtime($time))[0..6]];
|
|
}
|
|
}
|
|
|
|
return [$sec, $min, $hour, $day, $mon, $year, $dwk];
|
|
}
|
|
return;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{date_gmt_offset} = __LINE__ . <<'END_OF_SUB';
|
|
sub date_gmt_offset {
|
|
# ----------------------------------------------------
|
|
# Returns the offset from local to gmtime in seconds.
|
|
# This can be a negative number.
|
|
#
|
|
my @lt = localtime;
|
|
unless (defined $GM_OFFSET and $lt[8] == $GM_OFFSET_DST) {
|
|
$GM_OFFSET = timegm(@lt) - timelocal(@lt);
|
|
$GM_OFFSET_DST = $lt[8];
|
|
}
|
|
return $GM_OFFSET;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{timelocal} = __LINE__ . <<'END_OF_SUB';
|
|
sub timelocal {
|
|
# -------------------------------------------------------------------
|
|
# Returns unix time from a timelocal array.
|
|
#
|
|
my @date = @_ ? (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_) : localtime;
|
|
my $time = timegm (@date);
|
|
my $orig = $time;
|
|
|
|
my @lt = localtime ($time);
|
|
my @gt = gmtime ($time);
|
|
|
|
if ($time < DAY and ($lt[5] >= 70 or $gt[5] >= 70 )) {
|
|
$orig += DAY;
|
|
@lt = localtime($orig);
|
|
@gt = gmtime($orig);
|
|
}
|
|
my $tzsec = ($gt[1] - $lt[1]) * MIN + ($gt[2] - $lt[2]) * HOUR;
|
|
|
|
if ($lt[5] > $gt[5]) {
|
|
$tzsec -= DAY;
|
|
}
|
|
elsif ($gt[5] > $lt[5]) {
|
|
$tzsec += DAY;
|
|
}
|
|
else {
|
|
$tzsec += ($gt[7] - $lt[7]) * DAY;
|
|
}
|
|
$tzsec += HOUR if($lt[8]);
|
|
|
|
my $ret = $time + $tzsec;
|
|
my @test = localtime($ret + ($orig - $time));
|
|
$ret -= HOUR if $test[2] != $date[2];
|
|
return $ret;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{timegm} = __LINE__ . <<'END_OF_SUB';
|
|
sub timegm {
|
|
# -------------------------------------------------------------------
|
|
# Returns gm unix time based on a timelocal/gmtime array.
|
|
#
|
|
my @date = @_ ? (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_) : gmtime;
|
|
if ($date[5] > 999) {
|
|
$date[5] -= 1900;
|
|
}
|
|
while ($date[4] < 0) { # If a negative month gets passed in, add 12 months and subtract a year
|
|
$date[4] += 12;
|
|
$date[5]--;
|
|
}
|
|
while ($date[4] >= 12) { # If a month too large is passed in, subtract 12 months and add a year
|
|
$date[4] -= 12;
|
|
$date[5]++;
|
|
}
|
|
my $time_str = join "\0", map { defined $_ ? $_ : '' } @date;
|
|
my $time = $MONTH_YEAR{$time_str};
|
|
$time + $date[0] * SEC + $date[1] * MIN + $date[2] * HOUR + ($date[3]-1) * DAY;
|
|
}
|
|
END_OF_SUB
|
|
|
|
# ====================================================================== #
|
|
# PRIVATE FUNCTIONS #
|
|
# ====================================================================== #
|
|
|
|
$COMPILE{_date_str_to_time} = __LINE__ . <<'END_OF_SUB';
|
|
sub _date_str_to_time {
|
|
# ----------------------------------------------------
|
|
# Takes a date string and converts it to a unix time.
|
|
#
|
|
return unless (defined $_[0]);
|
|
my ($date, @lang) = split /\0/, $_[0];
|
|
if (@lang != 38) {
|
|
die "Invalid number of elements passed to _date_str_to_time: " . scalar @lang;
|
|
}
|
|
local @MONTHS = @lang[0 .. 11];
|
|
local @DAYS = @lang[12 .. 18];
|
|
local @MONTHS_SH = @lang[19 .. 30];
|
|
local @DAYS_SH = @lang[31 .. 37];
|
|
my $time_arr = parse_format($date) or return 0;
|
|
return timelocal (@$time_arr);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_format_date} = __LINE__ . <<'END_OF_SUB';
|
|
sub _format_date { format_date(@_); }
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_parse_format} = __LINE__ . <<'END_OF_SUB';
|
|
sub _parse_format { parse_format(@_) }
|
|
END_OF_SUB
|
|
|
|
|
|
$COMPILE{_parse_gmt_date} = __LINE__ . <<'END_OF_SUB';
|
|
sub _parse_gmt_date {
|
|
# ----------------------------------------------------
|
|
# attempts to turn a date string into a unix timestamp
|
|
#
|
|
my $in = shift || return timegm ( gmtime() );
|
|
my ($sec, $min, $hour, $day, $mon, $year);
|
|
|
|
# Handle + or - increments easily, just calculate current
|
|
# gmtime, and figure out desired offset and return.
|
|
if ($in =~ /^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
|
|
my %mult = (
|
|
's' => 1,
|
|
'm' => 60,
|
|
'h' => 60*60,
|
|
'd' => 60*60*24,
|
|
'M' => 60*60*24*30,
|
|
'y' => 60*60*24*365
|
|
);
|
|
my $gmtime = timegm( gmtime() );
|
|
$gmtime = $gmtime + ($mult{$2} || 1) * $1;
|
|
return $gmtime;
|
|
}
|
|
|
|
# Otherwise, we try and build a gmtime array, to pass
|
|
# to timegm.
|
|
if ( $in =~ s/(\d+):(\d+)(:(\d+))?\s*(am|pm)?//i ) {
|
|
( $hour, $min, $sec ) = ( $1 || 0, $2 ||0, $4 || 0 );
|
|
if ( ( $hour < 12 ) and ( lc($5) eq 'pm' ) ) { $hour += 12 }
|
|
if ( ( $hour == 12 ) and ( lc($5) eq 'am' ) ) { $hour = 0 }
|
|
}
|
|
|
|
# Try and find either the long month or short month.
|
|
my $mo_regex = join("|", ( @MONTHS, @MONTHS_SH ));
|
|
if ($in =~ /($mo_regex)/i ) {
|
|
my $mostr = $1;
|
|
$mon = $MONTH_HASH{$mostr};
|
|
$in =~ s/(\d+)?(st|nd|th)?\s*$mostr\s*(\d+)(st|nd|th)?//i;
|
|
if ( $1 > 31 ) {
|
|
$year = $1;
|
|
$day = $3;
|
|
}
|
|
else {
|
|
$day = $1 || $3;
|
|
if ( $day > 31 ) {
|
|
$year = $day;
|
|
$day = 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Try and get a four digit year.
|
|
if ($in =~ s/(\d\d\d\d)//) {
|
|
$year = $1;
|
|
}
|
|
|
|
# Try and get dd/mm/yy format.
|
|
if ($in =~ s,(\d+)/(\d+)/(\d+),,o) {
|
|
$day = $1;
|
|
$mon = $2;
|
|
$year = $3;
|
|
}
|
|
|
|
# If the word equals 'now', then use that.
|
|
my @local = gmtime();
|
|
$local[5] += 1900;
|
|
$local[4]++;
|
|
if ($in =~ s/now//) {
|
|
($sec, $min, $hour, $day, $mon, $year) = @local[ 0, 1, 2, 3, 4, 5 ];
|
|
}
|
|
else {
|
|
$day ||= $local[3];
|
|
$mon ||= $local[4];
|
|
$year ||= $local[5];
|
|
|
|
if (!defined($hour)) {
|
|
$hour ||= $local[2];
|
|
$min ||= $local[1];
|
|
$sec ||= $local[0];
|
|
}
|
|
}
|
|
|
|
# Make sure we have a four digit year.
|
|
($year < 99) and ($year += 1900);
|
|
|
|
# Timelocal needs month in same format as localtime (i.e. indexed from 0).
|
|
return timegm ($sec, $min, $hour, $day, $mon - 1, $year);
|
|
}
|
|
END_OF_SUB
|
|
|
|
|
|
$COMPILE{_calc_my} = __LINE__ . <<'END_OF_SUB';
|
|
sub _calc_my {
|
|
# -------------------------------------------------------------------
|
|
# Calculates the gmtime of the month and year.
|
|
#
|
|
my $date = shift;
|
|
my ($sec, $min, $hour, $day, $mon, $year) = split /\0/, $date;
|
|
if ($RANGE_CHECK) {
|
|
($mon > 11 or $mon < 0) and die "Month '$mon' out of range 0..1";
|
|
($day > 31 or $day < 1) and die "Day '$day' out of range 1..31";
|
|
($hour > 23 or $hour < 0) and die "Hour '$hour' out of range 0..23";
|
|
($min > 59 or $min < 0) and die "Minute '$min' out of range 0..59";
|
|
($sec > 59 or $sec < 0) and die "Second '$sec' out of range 0..59";
|
|
}
|
|
my $guess = $^T;
|
|
my @guess = gmtime ($guess);
|
|
my $last = '';
|
|
my $count = 0;
|
|
my $diff = 0;
|
|
|
|
# Calc year offset.
|
|
while ($diff = $year - $guess[5]) {
|
|
if ($count++ > 255) {
|
|
warn "GT::Date - can't handle date: $date\n" if ($LOUD);
|
|
return 0;
|
|
}
|
|
$guess += $diff * (363 * DAY);
|
|
@guess = gmtime ($guess);
|
|
if ("@guess" eq $last) {
|
|
warn "GT::Date - can't handle date: $date\n" if ($LOUD);
|
|
return 0;
|
|
}
|
|
$last = "@guess";
|
|
}
|
|
# Calc month offset.
|
|
while ($diff = $mon - $guess[4]) {
|
|
if ($count++ > 255) {
|
|
warn "GT::Date - can't handle date: $date\n" if ($LOUD);
|
|
return 0;
|
|
}
|
|
$guess += $diff * (27 * DAY);
|
|
@guess = gmtime ($guess);
|
|
if ("@guess" eq $last) {
|
|
warn "GT::Date - can't handle date: $date\n" if ($LOUD);
|
|
return 0;
|
|
}
|
|
$last = "@guess";
|
|
}
|
|
# We only want the month/year aspect.
|
|
$guess[3]--;
|
|
$guess -= $guess[0] * SEC + $guess[1] * MIN + $guess[2] * HOUR + $guess[3] * DAY;
|
|
return $guess;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_transform} = __LINE__ . <<'END_OF_SUB';
|
|
sub _transform {
|
|
# ----------------------------------------------------
|
|
# Transforms a date from one format to another, not called
|
|
# directly, accessed through cache.
|
|
#
|
|
my $key = shift;
|
|
my ($date, $orig, $new, @lang) = split /\0/, $key;
|
|
if (@lang != 38) {
|
|
die "Invalid number of elements passed to _date_str_to_time: " . scalar @lang;
|
|
}
|
|
local @MONTHS = @lang[0 .. 11];
|
|
local @DAYS = @lang[12 .. 18];
|
|
local @MONTHS_SH = @lang[19 .. 30];
|
|
local @DAYS_SH = @lang[31 .. 37];
|
|
|
|
my $time = parse_format ($date, $orig) or return;
|
|
return format_date ($time, $new);
|
|
}
|
|
END_OF_SUB
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::Date - Common date parsing and manipulation routines
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::Date qw/:all/;
|
|
my $date = date_get();
|
|
my $next_week = date_add($date, 7);
|
|
my $is_bigger = date_is_greater($date, $next_week);
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::Date provides several functions useful in parsing dates, and
|
|
doing date manipulation. Under the hood, it uses Time::Local
|
|
code to transform a date into seconds for comparison and
|
|
mathematical operations. It also uses L<GT::Cache> to store
|
|
most of the complex work.
|
|
|
|
No functions are exported by default. You can either specify
|
|
the functions you need in use, or use the tags ':all' or
|
|
':timelocal'. All will give you all functions, and timelocal
|
|
will give you functions found in Time::Local.
|
|
|
|
GT::Date uses a package global $DATE_FMT which specifies
|
|
the format that dates should be returned in. You can change this using
|
|
the date_set_format() function.
|
|
|
|
=head2 date_is_valid
|
|
|
|
Returns 1 if the argument passed in is a valid date. It must first
|
|
be in the current date format, and then be a valid date.
|
|
|
|
=head2 date_is_greater
|
|
|
|
Returns 1 if argument 1 is greater then argument 2, otherwise 0.
|
|
|
|
=head2 date_is_smaller
|
|
|
|
Returns 1 if argument 1 is smaller then argument 2, otherwise 0.
|
|
|
|
=head2 date_get date_get_gm
|
|
|
|
Called with no arguments, returns the current date based on system
|
|
time. You can specify the date you want by passing in the seconds
|
|
since epoch (output of time()).
|
|
|
|
=head2 date_comp
|
|
|
|
Equivalent to arg1 <=> arg2.
|
|
|
|
=head2 date_diff
|
|
|
|
Returns number of days difference between arg1 - arg2.
|
|
|
|
=head2 date_add date_add_gm
|
|
|
|
Returns date derived from arg1 + arg2, where the second argument
|
|
can be either a date or number of days.
|
|
|
|
=head2 date_sub date_sub_gm
|
|
|
|
Returns date derived from arg1 - arg2, where the second argument
|
|
can be either a date or number of days.
|
|
|
|
=head2 timegm
|
|
|
|
Takes the returned array from gmtime() and returns a unix time
|
|
stamp.
|
|
|
|
=head2 timlocal
|
|
|
|
Takes the array returned by localtime() and returns a unix time
|
|
stamp.
|
|
|
|
=head2 parse_format
|
|
|
|
Takes a string and a date format and returns an array
|
|
ref of the first 7 arguments returned by localtime().
|
|
|
|
=head2 format_date
|
|
|
|
Takes a localtime array, and a format string and returns a string
|
|
of the parsed format.
|
|
|
|
=head2 Setting date format
|
|
|
|
You can use date_set_format to change the format. You pass in a
|
|
format string. It is made up of:
|
|
|
|
%yyyy% four digit year as in 1999
|
|
%yy% two digit year as in 99
|
|
%y% two digit year without leading 0
|
|
%mmmm% long month name as in January
|
|
%mmm% short month name as in Jan
|
|
%mm% numerical month name as in 01
|
|
%m% numerical month name without leading 0 as in 1
|
|
%dddd% long day name as in Sunday
|
|
%ddd% short day name as in Sun
|
|
%dd% numerical date
|
|
%d% numerical date without leading 0
|
|
%HH% two digit hour, 24 hour time
|
|
%H% one or two digit hour, 24 hour time
|
|
%hh% two digit hour, 12 hour time. 0 becomes 12.
|
|
%h% one or two digit hour, 12 hour time. 0 becomes 12.
|
|
%MM% two digit minute
|
|
%M% one or two digit minute (when would someone ever WANT this?)
|
|
%ss% two digit second
|
|
%s% one ot two digit second (when would someone ever WANT this?)
|
|
%tt% AM or PM (use with 12 hour time)
|
|
%o% + or - GMT offset
|
|
|
|
Common formats include:
|
|
|
|
%yyyy%-%mm%-%dd% 1999-12-25
|
|
%dd%-%mmm%-%yyyy% 12-Dec-1999
|
|
%ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999
|
|
%ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999
|
|
|
|
or RFC822 mime mail format:
|
|
|
|
%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o% Sat, 12, Dec 1999 21:32:02 -0800
|
|
|
|
or MySQL format:
|
|
|
|
%yyyy%-%mm%-%dd% %HH%:%MM%:%ss% 1999-03-25 21:32:02
|
|
|
|
The language used for month names and day names can be changed with
|
|
date_set_month(), date_set_days(), date_set_days_short() and
|
|
date_set_month_short().
|
|
|
|
=head2 Transforming between date formats.
|
|
|
|
You can transform a date from one format to another with:
|
|
|
|
date_transform ($date, $orig_fmt, $new_fmt);
|
|
|
|
where $orig_fmt and $new_fmt are date format strings described above.
|
|
|
|
=head2 Getting the GM offset.
|
|
|
|
You can get the number of seconds between the system time and GM time
|
|
using:
|
|
|
|
my $time = date_gmt_offset();
|
|
|
|
So if you are in Pacific time, it would return 25200 seconds (-0700 time zone).
|
|
|
|
=head1 EXAMPLES
|
|
|
|
Get todays date, the default format unless specified is yyyy-mm-dd.
|
|
|
|
print date_get(); 2000-12-31
|
|
|
|
Get todays date in a different format:
|
|
|
|
date_set_format('%ddd% %mmm% %dd% %yyyy%');
|
|
print date_get(); Sat Dec 31 2000
|
|
|
|
Get the date from 1 week ago.
|
|
|
|
# Long way
|
|
my $date1 = date_get();
|
|
my $date2 = date_sub($date1, 7);
|
|
|
|
or
|
|
|
|
# Can pass in unix timestamp of date we want.
|
|
my $date = date_get (time - (7 * 86400));
|
|
|
|
Compare two dates.
|
|
|
|
my $halloween = '2000-10-31';
|
|
my $christmas = '2000-12-25';
|
|
if (date_is_smaller($halloween, $christmas)) {
|
|
print "Halloween comes before christmas!";
|
|
}
|
|
if (date_is_greater($christmas, $halloween)) {
|
|
print "Yup, christmas comes after halloween.";
|
|
}
|
|
my @dates = ($halloween, $christmas);
|
|
print "Dates in order: ", sort date_comp @dates;
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Date.pm,v 1.75 2005/04/04 22:21:23 brewt Exp $
|
|
|
|
=cut
|