# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Date
#   Author  : Aki Mimoto
#   CVS Info : 087,071,086,086,085      
#   $Id: Date.pm,v 1.81 2007/07/24 17:40:22 aki 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 %DATETIME_TZ/;
use GT::Cache;
use Exporter;
use GT::AutoLoader;

$VERSION    = sprintf "%d.%03d", q$Revision: 1.81 $ =~ /(\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
                 date_get_tz tz_all_names tz_local_name tz_is_valid
                /;
%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
    FORMAT_DATE => '%yyyy%-%mm%-%dd%',
    FORMAT_DATETIME => '%yyyy%-%mm%-%dd% %HH%:%MM%:%ss%',
    FORMAT_RFC822 => '%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o%';

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

sub date_get_tz {
# -----------------------------------------------------------------------------
# Takes an epoch time, a timezone (e.g. "America/Vancouver" or "+0630" or
# "local"), and a format (optional) and returns the formatted time for that
# timezone (or, if the timezone isn't valid, local time).  The global $OFFSET
# is intentionally ignored unless the timezone is invalid, in which case, local
# time is used, offset by the global $OFFSET.  Depends on the DateTime module
# (so wrap in an eval or test for DateTime before calling).
#
    my ($time, $timezone, $format) = @_;
    local $SIG{__DIE__}; # Localize as a die handler seems to cause problems when dying with a data structure
    require DateTime;
    require DateTime::TimeZone;
    my $utc = $DATETIME_TZ{UTC} ||= DateTime::TimeZone->new(name => 'UTC');
    my ($sec, $min, $hour, $day, $month, $year) = (gmtime($time || time))[0 .. 5];
    my $dt = DateTime->new(second => $sec, minute => $min, hour => $hour, day => $day, month => $month+1, year => $year+1900, time_zone => $utc);
    my $tz = defined $timezone ? $DATETIME_TZ{$timezone} : undef;
    my $use_offset;
    unless ($tz) {
        if (defined $timezone and not exists $DATETIME_TZ{$timezone}) {
            # If it exists but is undef it means it was already determined to be invalid
            $tz = eval { DateTime::TimeZone->new(name => $timezone) };
        }

        if ($tz) {
            $DATETIME_TZ{$timezone} = $tz;
        }
        else {
            # The timezone doesn't exist, so fall back to local (with $OFFSET)
            $tz = _tz_local();
            $use_offset = 1;
            $DATETIME_TZ{$timezone} = undef if defined $timezone;
        }
    }

    if ($use_offset) {
        require DateTime::Duration;
        $dt->add_duration(DateTime::Duration->new(seconds => $OFFSET));
    }

    $dt->set_time_zone($tz);
    my @localtime = (
        $dt->second, $dt->minute, $dt->hour,
        $dt->day, $dt->month_0, $dt->year - 1900,
        $dt->dow % 7, $dt->is_dst
    );

    return format_date(\@localtime, $format || $DATE_FMT);
}

$COMPILE{tz_all_names} = __LINE__ . <<'END_OF_SUB';
sub tz_all_names {
# -----------------------------------------------------------------------------
# Returns a list of all timezones known by the installed DateTime::TimeZone
# module (to be used with date_get_tz).
#
    local $SIG{__DIE__};
    require DateTime::TimeZone;
    return DateTime::TimeZone::all_names();
}
END_OF_SUB

$COMPILE{_tz_local} = __LINE__ . <<'END_OF_SUB';
sub _tz_local {
    return $DATETIME_TZ{local} if $DATETIME_TZ{local};

    local $SIG{__DIE__};
    require DateTime::TimeZone;

    $DATETIME_TZ{local} = eval { DateTime::TimeZone->new(name => "local") };

    if (!$DATETIME_TZ{local}) {
        # If DT::TZ can't determine what "local" time is, calculate an
        # offset and use that (though this approach is pretty much
        # guaranteed to be wrong across daylight saving time boundaries)
        my $now = time;
        my $utc_offset = (timegm(localtime $now) - timelocal(localtime $now)) / 60;
        $DATETIME_TZ{local} = DateTime::TimeZone->new(name => sprintf "%+03d%02d", $utc_offset / 60, $utc_offset % 60);
    }

    return $DATETIME_TZ{local};
}
END_OF_SUB

$COMPILE{tz_local_name} = __LINE__ . <<'END_OF_SUB';
sub tz_local_name {
# -----------------------------------------------------------------------------
# Determines and returns the name of the "local" timezone.
#
    return _tz_local()->name;
}
END_OF_SUB

$COMPILE{tz_is_valid} = __LINE__ . <<'END_OF_SUB';
sub tz_is_valid {
    local $SIG{__DIE__};
    require DateTime::TimeZone;

    my $zone_name = shift;

    unless (exists $DATETIME_TZ{$zone_name}) {
        $DATETIME_TZ{$zone_name} = eval { DateTime::TimeZone->new(name => $zone_name) };
    }

    return !!$DATETIME_TZ{$zone_name};
}
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 timelocal

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.81 2007/07/24 17:40:22 aki Exp $

=cut
