# ================================================================== # 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 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