Gecko [ fernandoquevedodop.com ]

Name	Size	Permission
CTime.pm	5.64 KB	-rw-r--r--
DaysInMonth.pm	1.3 KB	-rw-r--r--
JulianDay.pm	5.8 KB	-rw-r--r--
ParseDate.pm	29.2 KB	-rw-r--r--
Stopwatch.pm	4.92 KB	-rw-r--r--
Timezone.pm	9.41 KB	-rw-r--r--
Zone.pm	8.15 KB	-rw-r--r--

Code Editor : ParseDate.pm

package Time::ParseDate;

require 5.000;

use Carp;
use Time::Timezone;
use Time::JulianDay;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(parsedate);
@EXPORT_OK = qw(pd_raw %mtable %umult %wdays);

use strict;
#use diagnostics;

# constants
use vars qw(%mtable %umult %wdays $VERSION);

$VERSION = 2015.1030;

# globals
use vars qw($debug);

# dynamically-scoped
use vars qw($parse);

my %mtable;
my %umult;
my %wdays;
my $y2k;

CONFIG:	{

%mtable = qw(
		Jan 1	Jan. 1	January 1
		Feb 2	Feb. 2	February 2
		Mar 3	Mar. 3	March 3
		Apr 4	Apr. 4	April 4
		May 5 
		Jun 6	Jun. 6	June 6 
		Jul 7	Jul. 7	July 7 
		Aug 8	Aug. 8	August 8 
		Sep 9	Sep. 9	September 9 Sept 9
		Oct 10	Oct. 10	October 10 
		Nov 11	Nov. 11	November 11 
		Dec 12	Dec. 12	December 12 );
	%umult = qw(
		sec 1 second 1
		min 60 minute 60
		hour 3600
		day 86400
		week 604800 
		fortnight 1209600);
	%wdays = qw(
		sun 0 sunday 0
		mon 1 monday 1
		tue 2 tuesday 2
		wed 3 wednesday 3
		thu 4 thursday 4
		fri 5 friday 5
		sat 6 saturday 6
		);

$y2k = 946684800; # turn of the century
}

my $break = qr{(?:\s+|\Z|\b(?![-:.,/]\d))};

sub parsedate
{
	my ($t, %options) = @_;

my ($y, $m, $d);	# year, month - 1..12, day
	my ($H, $M, $S);	# hour, minute, second
	my $tz;		 	# timezone
	my $tzo;		# timezone offset
	my ($rd, $rs);		# relative days, relative seconds

my $rel; 		# time&|date is relative

my $isspec;
	my $now = defined($options{NOW}) ? $options{NOW} : time;
	my $passes = 0;
	my $uk = defined($options{UK}) ? $options{UK} : 0;

local $parse = '';  # will be dynamically scoped.

if ($t =~ s#^   ([ \d]\d) 
			/ (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)
			/ (\d\d\d\d)
			: (\d\d)
			: (\d\d)
			: (\d\d)
			(?:
			 [ ]
			 ([-+] \d\d\d\d)
			  (?: $"?(?:(?:[A-Z]{1,4}[TCW56])|IDLE)$)?
			 )?
			 $break
			##xi) { #"emacs
		# [ \d]/Mon/yyyy:hh:mm:ss [-+]\d\d\d\d
		# This is the format for www server logging.

($d, $m, $y, $H, $M, $S, $tzo) = ($1, $mtable{"\u\L$2"}, $3, $4, $5, $6, $7 ? &mkoff($7) : ($tzo || undef));
		$parse .= " ".__LINE__ if $debug;
	} elsif ($t =~ s#^(\d\d)/(\d\d)/(\d\d)\.(\d\d)\:(\d\d)($break)##) {
		# yy/mm/dd.hh:mm
		# I support this format because it's used by wbak/rbak
		# on Apollo Domain OS.  Silly, but historical.

($y, $m, $d, $H, $M, $S) = ($1, $2, $3, $4, $5, 0);
		$parse .= " ".__LINE__ if $debug;
	} else {
		while(1) {
			if (! defined $m and ! defined $rd and ! defined $y
				and ! ($passes == 0 and $options{'TIMEFIRST'}))
			{
				# no month defined.
				if (&parse_date_only(\$t, \$y, \$m, \$d, $uk)) {
					$parse .= " ".__LINE__ if $debug;
					next;
				}
			}
			if (! defined $H and ! defined $rs) {
				if (&parse_time_only(\$t, \$H, \$M, \$S, 
					\$tz, %options)) 
				{
					$parse .= " ".__LINE__ if $debug;
					next;
				}
			}
			next if $passes == 0 and $options{'TIMEFIRST'};
			if (! defined $y) {
				if (&parse_year_only(\$t, \$y, $now, %options)) {
					$parse .= " ".__LINE__ if $debug;
					next;
				}
			}
			if (! defined $tz and ! defined $tzo and ! defined $rs 
				and (defined $m or defined $H)) 
			{
				if (&parse_tz_only(\$t, \$tz, \$tzo)) {
					$parse .= " ".__LINE__ if $debug;
					next;
				}
			}
			if (! defined $H and ! defined $rs) {
				if (&parse_time_offset(\$t, \$rs, %options)) {
					$rel = 1;
					$parse .= " ".__LINE__ if $debug;
					next;
				}
			}
			if (! defined $m and ! defined $rd and ! defined $y) {
				if (&parse_date_offset(\$t, $now, \$y, 
					\$m, \$d, \$rd, \$rs, %options)) 
				{
					$rel = 1;
					$parse .= " ".__LINE__ if $debug;
					next;
				}
			}
			if (defined $M or defined $rd) {
				if ($t =~ s/^\s*(?:at|\@|\+)($break)//x) {
					$rel = 1;
					$parse .= " ".__LINE__ if $debug;
					next;
				}
			}
			last;
		} continue {
			$passes++;
			&debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;

}

if ($passes == 0) {
			print "nothing matched\n" if $debug;
			return (undef, "no match on time/date") 
				if wantarray();
			return undef;
		}
	}

&debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;

$t =~ s/^\s+//;

if ($t ne '') {
		# we didn't manage to eat the string
		print "NOT WHOLE\n" if $debug;
		if ($options{WHOLE}) {
			return (undef, "characters left over after parse")
				if wantarray();
			return undef 
		}
	}

# define a date if there isn't one already

if (! defined $y and ! defined $m and ! defined $rd) {
		print "no date defined, trying to find one." if $debug;
		if (defined $rs or defined $H) {
			# we do have a time.
			if ($options{DATE_REQUIRED}) {
				return (undef, "no date specified")
					if wantarray();
				return undef;
			}
			if (defined $rs) {
				print "simple offset: $rs\n" if $debug;
				my $rv = $now + $rs;
				return ($rv, $t) if wantarray();
				return $rv;
			}
			$rd = 0;
		} else {
			print "no time either!\n" if $debug;
			return (undef, "no time specified")
				if wantarray();
			return undef;
		}
	}

if ($options{TIME_REQUIRED} && ! defined($rs) 
		&& ! defined($H) && ! defined($rd))
	{
		return (undef, "no time found")
			if wantarray();
		return undef;
	}

my $secs;
	my $jd;

if (defined $rd) {
		if (defined $rs || ! (defined($H) || defined($M) || defined($S))) {
			print "fully relative\n" if $debug;
			my ($j, $in, $it);
			my $definedrs = defined($rs) ? $rs : 0;
			my ($isdst_now, $isdst_then);
			my $r = $now + $rd * 86400 + $definedrs;
			#
			# It's possible that there was a timezone shift 
			# during the time specified.  If so, keep the
			# hours the "same".
			#
			$isdst_now = (localtime($r))[8];
			$isdst_then = (localtime($now))[8];
			if (($isdst_now == $isdst_then) || $options{GMT})
			{
				return ($r, $t) if wantarray();
				return $r 
			}
				
			print "localtime changed DST during time period!\n" if $debug;
		}

print "relative date\n" if $debug;
		$jd = $options{GMT}
			? gm_julian_day($now)
			: local_julian_day($now);
		print "jd($now) = $jd\n" if $debug;
		$jd += $rd;
	} else {
		unless (defined $y) {
			if ($options{PREFER_PAST}) {
				my ($day, $mon011);
				($day, $mon011, $y) = (&righttime($now))[3,4,5];

print "calc year -past $day-$d $mon011-$m $y\n" if $debug;
				$y -= 1 if ($mon011+1 < $m) || 
					(($mon011+1 == $m) && ($day < $d));
			} elsif ($options{PREFER_FUTURE}) {
				print "calc year -future\n" if $debug;
				my ($day, $mon011);
				($day, $mon011, $y) = (&righttime($now))[3,4,5];
				$y += 1 if ($mon011 >= $m) || 
					(($mon011+1 == $m) && ($day > $d));
			} else {
				print "calc year -this\n" if $debug;
				$y = (localtime($now))[5];
			}
			$y += 1900;
		}

$y = expand_two_digit_year($y, $now, %options)
			if $y < 100;

if ($options{VALIDATE}) {
			require Time::DaysInMonth;
			my $dim = Time::DaysInMonth::days_in($y, $m);
			if ($y < 1000 or $m < 1 or $d < 1 
				or $y > 9999 or $m > 12 or $d > $dim)
			{
				return (undef, "illegal YMD: $y, $m, $d")
					if wantarray();
				return undef;
			}
		}
		$jd = julian_day($y, $m, $d);
		print "jd($y, $m, $d) = $jd\n" if $debug;
	}

# put time into HMS

if (! defined($H)) {
		if (defined($rd) || defined($rs)) {
			($S, $M, $H) = &righttime($now, %options);
			print "HMS set to $H $M $S\n" if $debug;
		} 
	}

my $carry;

print "before ", (defined($rs) ? "$rs" : ""),
		    " $jd $H $M $S\n" 
		if $debug;
	#
	# add in relative seconds.  Do it this way because we want to
	# preserve the localtime across DST changes.
	#

$S = 0 unless $S; # -w
	$M = 0 unless $M; # -w
	$H = 0 unless $H; # -w

if ($options{VALIDATE} and
		($S < 0 or $M < 0 or $H < 0 or $S > 59 or $M > 59 or $H > 23)) 
	{
		return (undef, "illegal HMS: $H, $M, $S") if wantarray();
		return undef;
	}

$S += $rs if defined $rs;
	$carry = int($S / 60) - ($S < 0 && $S % 60 && 1);
	$S -= $carry * 60;
	$M += $carry;
	$carry = int($M / 60) - ($M < 0 && $M % 60 && 1);
	$M %= 60;
	$H += $carry;
	$carry = int($H / 24) - ($H < 0 && $H % 24 && 1);
	$H %= 24;
	$jd += $carry;

print "after rs  $jd $H $M $S\n" if $debug;

$secs = jd_secondsgm($jd, $H, $M, $S);
	print "jd_secondsgm($jd, $H, $M, $S) = $secs\n" if $debug;

# 
	# If we see something link 3pm CST then and we want to end
	# up with a GMT seconds, then we convert the 3pm to GMT and
	# subtract in the offset for CST.  We subtract because we
	# are converting from CST to GMT.
	#
	my $tzadj;
	if ($tz) {
		$tzadj = tz_offset($tz, $secs);
		if (defined $tzadj) {
			print "adjusting secs for $tz: $tzadj\n" if $debug;
			$tzadj = tz_offset($tz, $secs-$tzadj);
			$secs -= $tzadj;
		} else {
			print "unknown timezone: $tz\n" if $debug;
			undef $secs;
			undef $t;
		}
	} elsif (defined $tzo) {
		print "adjusting time for offset: $tzo\n" if $debug;
		$secs -= $tzo;
	} else {
		unless ($options{GMT}) {
			if ($options{ZONE}) {
				$tzadj = tz_offset($options{ZONE}, $secs) || 0;
				$tzadj = tz_offset($options{ZONE}, $secs-$tzadj);
				unless (defined($tzadj)) {
					return (undef, "could not convert '$options{ZONE}' to time offset")
						if wantarray();
					return undef;
				}
				print "adjusting secs for $options{ZONE}: $tzadj\n" if $debug;
				$secs -= $tzadj;
			} else {
				$tzadj = tz_local_offset($secs);
				print "adjusting secs for local offset: $tzadj\n" if $debug;
				# 
				# Just in case we are very close to a time
				# change...
				#
				$tzadj = tz_local_offset($secs-$tzadj);
				$secs -= $tzadj;
			}
		}
	}

print "returning $secs.\n" if $debug;

return ($secs, $t) if wantarray();
	return $secs;
}

sub mkoff
{
	my($offset) = @_;

if (defined $offset and $offset =~ s#^([-+])(\d\d):?(\d\d)$##) {
		return ($1 eq '+' ? 
			  3600 * $2  + 60 * $3
			: -3600 * $2 + -60 * $3 );
	}
	return undef;
}

sub parse_tz_only
{
	my($tr, $tz, $tzo) = @_;

$$tr =~ s#^\s+##;
	my $o;

if ($$tr =~ s#^
			([-+]\d\d:?\d\d)
			\s+
			$
				"?
				(?:
					(?:
						[A-Z]{1,4}[TCW56]
					)
					|
					IDLE
				)
			$
			$break
			##x) { #"emacs
		$$tzo = &mkoff($1);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^GMT\s*([-+]\d{1,2})($break)##x) {
		$o = $1;
		if ($o < 24 and $o !~ /^0/) {
			# probably hours.
			printf "adjusted at %d. ($o 00)\n", __LINE__ if $debug;
			$o = "${o}00";
		}
		$o =~ s/\b(\d\d\d)/0$1/;
		$$tzo = &mkoff($o);
		printf "matched at %d. ($$tzo, $o)\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?:GMT\s*)?([-+]\d\d:?\d\d)($break)##x) {
		$o = $1;
		$$tzo = &mkoff($o);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^"?((?:[A-Z]{1,4}[TCW56])|IDLE)$break##x) { #"
		$$tz = $1;
		$$tz .= " DST" 
			if $$tz eq 'MET' && $$tr =~ s#^DST$break##x;
		printf "matched at %d: '$$tz'.\n", __LINE__ if $debug;
		return 1;
	}
	return 0;
}

sub parse_date_only
{
	my ($tr, $yr, $mr, $dr, $uk) = @_;

$$tr =~ s#^\s+##;

if ($$tr =~ s#^(\d\d\d\d)([-./])(\d\d?)\2(\d\d?)(T|$break)##) {
		# yyyy/mm/dd

($$yr, $$mr, $$dr) = ($1, $3, $4);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(\d\d?)([-./])(\d\d?)\2(\d\d\d\d?)($break)##) {
		# mm/dd/yyyy - is this safe?  No.
		# -- or dd/mm/yyyy! If $1>12, then it's unambiguous.
		# Otherwise check option UK for UK style date.
		if ($uk || $1>12) {
		  ($$yr, $$mr, $$dr) = ($4, $3, $1);
		} else {
		  ($$yr, $$mr, $$dr) = ($4, $1, $3);
		}
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(\d\d\d\d)/(\d\d?)$break##x) {
		# yyyy/mm

($$yr, $$mr, $$dr) = ($1, $2, 1);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(?:
				(?:Mon|Monday|Tue|Tuesday|Wed|Wednesday|
					Thu|Thursday|Fri|Friday|
					Sat|Saturday|Sun|Sunday),?
				\s+
			)?
			(\d\d?)
			(\s+ | - | \. | /)
			(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\.?
			(?:
				\2
				(\d\d (?:\d\d)? )
			)?
			$break
			##) {
		# [Dow,] dd Mon [yy[yy]]
		($$yr, $$mr, $$dr) = ($4, $mtable{"\u\L$3"}, $1);

printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $3 if $debug;
		print "y undef\n" if ($debug && ! defined($$yr));
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(?:
				(?:Mon|Monday|Tue|Tuesday|Wed|Wednesday|
					Thu|Thursday|Fri|Friday|
					Sat|Saturday|Sun|Sunday),?
				\s+
			)?
			(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\.?
			((\s)+ | - | \. | /)
				
			(\d\d?)
			,?
			(?:
				(?: \2|\3+)
				(\d\d (?: \d\d)?)
			)?
			$break
			##) {
		# [Dow,] Mon dd [yyyy]
		# [Dow,] Mon d, [yy]
		($$yr, $$mr, $$dr) = ($5, $mtable{"\u\L$1"}, $4);
		printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $4 if $debug;
		print "y undef\n" if ($debug && ! defined($$yr));
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
			    June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
			    October|Oct\.?|November|Nov\.?|December|Dec\.?)
			\s+
			(\d+)
			(?:st|nd|rd|th)?
			\,?
			(?: 
				\s+
				(?:
					(\d\d\d\d)
					|(?:\' (\d\d))
				)
			)?
			$break
			##) {
		# Month day{st,nd,rd,th}, 'yy
		# Month day{st,nd,rd,th}, year
		# Month day, year
		# Mon. day, year
		($$yr, $$mr, $$dr) = ($3 || $4, $mtable{"\u\L$1"}, $2);
		printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
		print "y undef\n" if ($debug && ! defined($$yr));
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(\d\d?)([-/.])(\d\d?)\2(\d\d?)($break)##x) {
		if ($1 > 31 || (!$uk && $1 > 12 && $4 < 32)) {
			# yy/mm/dd
			($$yr, $$mr, $$dr) = ($1, $3, $4);
		} elsif ($1 > 12 || $uk) {
			# dd/mm/yy
			($$yr, $$mr, $$dr) = ($4, $3, $1);
		} else {
			# mm/dd/yy
			($$yr, $$mr, $$dr) = ($4, $1, $3);
		}
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(\d\d?)/(\d\d?)($break)##x) {
		if ($1 > 31 || (!$uk && $1 > 12)) {
			# yy/mm
			($$yr, $$mr, $$dr) = ($1, $2, 1);
		} elsif ($2 > 31 || ($uk && $2 > 12)) {
			# mm/yy
			($$yr, $$mr, $$dr) = ($2, $1, 1);
		} elsif ($1 > 12 || $uk) {
			# dd/mm
			($$mr, $$dr) = ($2, $1);
		} else {
			# mm/dd
			($$mr, $$dr) = ($1, $2);
		}
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(\d\d)(\d\d)(\d\d)($break)##x) {
		if ($1 > 31 || (!$uk && $1 > 12)) {
			# YYMMDD
			($$yr, $$mr, $$dr) = ($1, $2, $3);
		} elsif ($1 > 12 || $uk) {
			# DDMMYY
			($$yr, $$mr, $$dr) = ($3, $2, $1);
		} else {
			# MMDDYY
			($$yr, $$mr, $$dr) = ($3, $1, $2);
		}
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(\d{1,2})
			(\s+ | - | \. | /)
			(January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
			    June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
			    October|Oct\.?|November|Nov\.?|December|Dec\.?)
			(?:
				\2
				(
					\d\d
					(?:\d\d)?
				)
			)
			$break
			##) {
		# dd Month [yr]
		($$yr, $$mr, $$dr) = ($4, $mtable{"\u\L$3"}, $1);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(\d+)
			(?:st|nd|rd|th)?
			\s+
			(January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
			    June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
			    October|Oct\.?|November|Nov\.?|December|Dec\.?)
			(?: 
				\,?
				\s+
				(\d\d\d\d)
			)?
			$break
			##) {
		# day{st,nd,rd,th}, Month year
		($$yr, $$mr, $$dr) = ($3, $mtable{"\u\L$2"}, $1);
		printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
		print "y undef\n" if ($debug && ! defined($$yr));
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	}
	return 0;
}

sub parse_time_only
{
	my ($tr, $hr, $mr, $sr, $tzr, %options) = @_;

$$tr =~ s#^\s+##;

if ($$tr =~ s!^(?x)
			(?:
				(?:
					([012]\d)		(?# $1)
					(?:
						([0-5]\d) 	(?# $2)
						(?:
						    ([0-5]\d)	(?# $3)
						)?
					)
					\s*
					([apAP][mM])?  		(?# $4)
				) | (?:
					(\d{1,2}) 		(?# $5)
					(?:
						\:
						(\d\d)		(?# $6)
						(?:
							\:
							(\d\d)	(?# $7)
								(
									(?# don't barf on database sub-second timings)
									[:.,]
									\d+
								)?	(?# $8)
						)?
					)
					\s*
					([apAP][mM])?		(?# $9)
				) | (?:
					(\d{1,2})		(?# $10)
					([apAP][mM])		(?# ${11})
				)
			)
			(?:
				\s+
				"?
				(				(?# ${12})
					(?: [A-Z]{1,4}[TCW56] )
					|
					IDLE
				)	
			)?
			$break
			!!) { #"emacs
		# HH[[:]MM[:SS]]meridian [zone] 
		my $ampm;
		$$hr = $1 || $5 || $10 || 0; # 10 is undef, but 5 is defined..
		$$mr = $2 || $6 || 0;
		$$sr = $3 || $7 || 0;
		if (defined($8) && exists($options{SUBSECOND}) && $options{SUBSECOND}) {
			my($frac) = $8;
			substr($frac,0,1) = '.';
			$$sr += $frac;
		}
		print "S = $$sr\n" if $debug;
		$ampm = $4 || $9 || $11 || '';
		$$tzr = $12;
		$$hr += 12 if $ampm and "\U$ampm" eq "PM" && $$hr != 12;
		$$hr = 0 if $$hr == 12 && "\U$ampm" eq "AM";
		printf "matched at %d, rem = %s.\n", __LINE__, $$tr if $debug;
		return 1;
	} elsif ($$tr =~ s#^noon$break##ix) {
		# noon
		($$hr, $$mr, $$sr) = (12, 0, 0);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^midnight$break##ix) {
		# midnight
		($$hr, $$mr, $$sr) = (0, 0, 0);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	}
	return 0;
}

sub parse_time_offset
{
	my ($tr, $rsr, %options) = @_;

$$tr =~ s/^\s+//;

return 0 if $options{NO_RELATIVE};

if ($$tr =~ s{^(?xi)					
			(?:
				(-)				(?# 1)
				|
				[+]
			)?
			\s*
			(?:
				(\d+(?:\.\d+)?) 		(?# 2)
				| 		
				(?:(\d+)\s+(\d+)/(\d+))		(?# 3 4/5)
			)
			\s*
			(sec|second|min|minute|hour)s?		(?# 6)
			(
				\s+
				ago				(?# 7)
			)?
			$break
			}{}) {
		# count units
		$$rsr = 0 unless defined $$rsr;
		return 0 if defined($5) && $5 == 0;
		my $num = defined($2)
			? $2
			: $3 + $4/$5;
		$num = -$num if $1;
		$$rsr += $umult{"\L$6"} * $num;

$$rsr = -$$rsr if $7 ||
			$$tr =~ /\b(day|mon|month|year)s?\s*ago\b/;
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} 
	return 0;
}

#
# What to you do with a date that has a two-digit year?
# There's not much that can be done except make a guess.
#
# Some example situations to handle:
#
#	now		year 
#
#	1999		01
#	1999		71
#	2010		71
#	2110		09
#

sub expand_two_digit_year
{
	my ($yr, $now, %options) = @_;

return $yr if $yr > 100;

my ($y) = (&righttime($now, %options))[5];
	$y += 1900;
	my $century = int($y / 100) * 100;
	my $within = $y % 100;

my $r = $yr + $century;

if ($options{PREFER_PAST}) {
		if ($yr > $within) {
			$r = $yr + $century - 100;
		}
	} elsif ($options{PREFER_FUTURE}) {
		# being strict here would be silly
		if ($yr < $within-20) {
			# it's 2019 and the date is '08'
			$r = $yr + $century + 100;
		}
	} elsif ($options{UNAMBIGUOUS}) {
		# we really shouldn't guess
		return undef;
	} else {
		# prefer the current century in most cases

if ($within > 80 && $within - $yr > 60) {
			$r = $yr + $century + 100;
		}

if ($within < 30 && $yr - $within > 59) {
			$r = $yr + $century - 100;
		}
	}
	print "two digit year '$yr' expanded into $r\n" if $debug;
	return $r;
}

sub calc 
{
	my ($rsr, $yr, $mr, $dr, $rdr, $now, $units, $count, %options) = @_;

confess unless $units;
	$units = "\L$units";
	print "calc based on $units\n" if $debug;

if ($units eq 'day') {
		$$rdr = $count;
	} elsif ($units eq 'week') {
		$$rdr = $count * 7;
	} elsif ($umult{$units}) {
		$$rsr = $count * $umult{$units};
	} elsif ($units eq 'mon' || $units eq 'month') {
		($$yr, $$mr, $$dr) = &monthoff($now, $count, %options);
		$$rsr = 0 unless $$rsr;
	} elsif ($units eq 'year') {
		($$yr, $$mr, $$dr) = &monthoff($now, $count * 12, %options);
		$$rsr = 0 unless $$rsr;
	} else {
		carp "interal error";
	}
	print "calced rsr $$rsr rdr $$rdr, yr $$yr mr $$mr dr $$dr.\n" if $debug;
}

sub monthoff
{
	my ($now, $months, %options) = @_;

# months are 0..11
	my ($d, $m11, $y) = (&righttime($now, %options)) [ 3,4,5 ] ;

$y += 1900;

print "m11 = $m11 + $months, y = $y\n" if $debug;

$m11 += $months;

print "m11 = $m11, y = $y\n" if $debug;
	if ($m11 > 11 || $m11 < 0) {
		$y -= 1 if $m11 < 0 && ($m11 % 12 != 0);
		$y += int($m11/12);

# this is required to work around a bug in perl 5.003
		no integer;
		$m11 %= 12;
	}
	print "m11 = $m11, y = $y\n" if $debug;

# 
	# What is "1 month from January 31st?"  
	# I think the answer is February 28th most years.
	#
	# Similarly, what is one year from February 29th, 1980?
	# I think it's February 28th, 1981.
	#
	# If you disagree, change the following code.
	#
	if ($d > 30 or ($d > 28 && $m11 == 1)) {
		require Time::DaysInMonth;
		my $dim = Time::DaysInMonth::days_in($y, $m11+1);
		print "dim($y,$m11+1)= $dim\n" if $debug;
		$d = $dim if $d > $dim;
	}
	return ($y, $m11+1, $d);
}

sub righttime
{
	my ($time, %options) = @_;
	if ($options{GMT}) {
		return gmtime($time);
	} else {
		return localtime($time);
	}
}

sub parse_year_only
{
	my ($tr, $yr, $now, %options) = @_;

$$tr =~ s#^\s+##;

if ($$tr =~ s#^(\d\d\d\d)$break##) {
		$$yr = $1;
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#\'(\d\d)$break##) {
		$$yr = expand_two_digit_year($1, $now, %options);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	}
	return 0;
}

sub parse_date_offset
{
	my ($tr, $now, $yr, $mr, $dr, $rdr, $rsr, %options) = @_;

return 0 if $options{NO_RELATIVE};

# now - current seconds_since_epoch
	# yr - year return
	# mr - month return
	# dr - day return
	# rdr - relative day return
	# rsr - relative second return

my $j;
	my $wday = (&righttime($now, %options))[6];

$$tr =~ s#^\s+##;

if ($$tr =~ s#^(?xi)
			\s*
			(\d+)
			\s*
			(day|week|month|year)s?
			(
				\s+
				ago
			)?
			$break
			##) {
		my $amt = $1 + 0;
		my $units = $2;
		$amt = -$amt if $3 ||
			$$tr =~ m#\b(sec|second|min|minute|hour)s?\s*ago\b#;
		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $units, 
			$amt, %options);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(?:
				(?:
					now
					\s+
				)?
				(\+ | \-)
				\s*
			)?
			(\d+)
			\s*
			(day|week|month|year)s?
			$break
			##) {
		my $one = $1 || '';
		my $two = $2 || '';
		my $amt = "$one$two"+0;
		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $3, 
			$amt, %options);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
				|Wednesday|Thursday|Friday|Saturday|Sunday)
			\s+
			after
			\s+
			next
			$break
			##) {
		# Dow "after next"
		$$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} > $wday ? 7 : 14);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
				|Wednesday|Thursday|Friday|Saturday|Sunday)
			\s+
			before
			\s+
			last
			$break
			##) {
		# Dow "before last"
		$$rdr = $wdays{"\L$1"} - $wday - ( $wdays{"\L$1"} < $wday ? 7 : 14);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			next\s+
			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
				|Wednesday|Thursday|Friday|Saturday|Sunday)
			$break
			##) {
		# "next" Dow
		$$rdr = $wdays{"\L$1"} - $wday 
				+ ( $wdays{"\L$1"} > $wday ? 0 : 7);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^(?xi)
			last\s+
			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
				|Wednesday|Thursday|Friday|Saturday|Sunday)
			$break##) {
		# "last" Dow
		printf "c %d - %d + ( %d < %d ? 0 : -7 \n", $wdays{"\L$1"},  $wday,  $wdays{"\L$1"}, $wday if $debug;
		$$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} < $wday ? 0 : -7);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($options{PREFER_PAST} and $$tr =~ s#^(?xi)
			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
				|Wednesday|Thursday|Friday|Saturday|Sunday)
			$break##) {
		# Dow
		printf "c %d - %d + ( %d < %d ? 0 : -7 \n", $wdays{"\L$1"},  $wday,  $wdays{"\L$1"}, $wday if $debug;
		$$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} < $wday ? 0 : -7);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($options{PREFER_FUTURE} and $$tr =~ s#^(?xi)
			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
				|Wednesday|Thursday|Friday|Saturday|Sunday)
			$break
			##) {
		# Dow
		$$rdr = $wdays{"\L$1"} - $wday 
				+ ( $wdays{"\L$1"} > $wday ? 0 : 7);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^today$break##xi) {
		# today
		$$rdr = 0;
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^tomorrow$break##xi) {
		$$rdr = 1;
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^yesterday$break##xi) {
		$$rdr = -1;
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^last\s+(week|month|year)$break##xi) {
		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $1, -1, %options);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^next\s+(week|month|year)$break##xi) {
		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $1, 1, %options);
		printf "matched at %d.\n", __LINE__ if $debug;
		return 1;
	} elsif ($$tr =~ s#^now $break##x) {
		$$rdr = 0;
		return 1;
	}
	return 0;
}

sub debug_display
{
	my ($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) = @_;
	print "---------<<\n";
	print defined($tz) ? "tz: $tz.\n" : "no tz\n";
	print defined($tzo) ? "tzo: $tzo.\n" : "no tzo\n";
	print "HMS: ";
	print defined($H) ? "$H, " : "no H, ";
	print defined($M) ? "$M, " : "no M, ";
	print defined($S) ? "$S\n" : "no S.\n";
	print "mdy: ";
	print defined($m) ? "$m, " : "no m, ";
	print defined($d) ? "$d, " : "no d, ";
	print defined($y) ? "$y\n" : "no y.\n";
	print defined($rs) ? "rs: $rs.\n" : "no rs\n";
	print defined($rd) ? "rd: $rd.\n" : "no rd\n";
	print $rel ? "relative\n" : "not relative\n";
	print "passes: $passes\n";
	print "parse:$parse\n";
	print "t: $t.\n";
	print "--------->>\n";
}
1;

__END__

=head1 NAME

Time::ParseDate -- date parsing both relative and absolute

=head1 SYNOPSIS

use Time::ParseDate;
	$seconds_since_jan1_1970 = parsedate("12/11/94 2pm", NO_RELATIVE => 1)
	$seconds_since_jan1_1970 = parsedate("12/11/94 2pm", %options)

=head1 OPTIONS

Date parsing can also use options.  The options are as follows:

FUZZY	-> it's okay not to parse the entire date string
	NOW	-> the "current" time for relative times (defaults to time())
	ZONE	-> local timezone (defaults to $ENV{TZ})
	WHOLE	-> the whole input string must be parsed
	GMT	-> input time is assumed to be GMT, not localtime
	UK	-> prefer UK style dates (dd/mm over mm/dd)
	DATE_REQUIRED -> do not default the date
	TIME_REQUIRED -> do not default the time
	NO_RELATIVE -> input time is not relative to NOW
	TIMEFIRST -> try parsing time before date [not default]
	PREFER_PAST -> when year or day of week is ambiguous, assume past
	PREFER_FUTURE -> when year or day of week is ambiguous, assume future
	SUBSECOND -> parse fraction seconds
	VALIDATE -> only accept normal values for HHMMSS, YYMMDD.  Otherwise
		days like -1 might give the last day of the previous month.

=head1 DATE FORMATS RECOGNIZED

=head2 Absolute date formats

Dow, dd Mon yy
	Dow, dd Mon yyyy
	Dow, dd Mon
	dd Mon yy
	dd Mon yyyy
	Month day{st,nd,rd,th}, year
	Month day{st,nd,rd,th}
	Mon dd yyyy
	yyyy/mm/dd
	yyyy-mm-dd	(usually the best date specification syntax)
	yyyy/mm
	mm/dd/yy
	mm/dd/yyyy
	mm/yy
	yy/mm      (only if year > 12, or > 31 if UK)
	yy/mm/dd   (only if year > 12 and day < 32, or year > 31 if UK)
	dd/mm/yy   (only if UK, or an invalid mm/dd/yy or yy/mm/dd)
	dd/mm/yyyy (only if UK, or an invalid mm/dd/yyyy)
	dd/mm      (only if UK, or an invalid mm/dd)

=head2 Relative date formats:

count "days"
	count "weeks"
	count "months"
	count "years"
	Dow "after next"
	Dow "before last"
	Dow 			(requires PREFER_PAST or PREFER_FUTURE)
	"next" Dow
	"tomorrow"
	"today"
	"yesterday"
	"last" dow
	"last week"
	"now"
	"now" "+" count units
	"now" "-" count units
	"+" count units		
	"-" count units
	count units "ago"

=head2 Absolute time formats:

hh:mm:ss[.ddd] 
	hh:mm 
	hh:mm[AP]M
	hh[AP]M
	hhmmss[[AP]M] 
	"noon"
	"midnight"

=head2 Relative time formats:

count "minutes"		(count can be franctional "1.5" or "1 1/2")
	count "seconds"
	count "hours"
	"+" count units
	"+" count
	"-" count units
	"-" count
	count units "ago"

=head2 Timezone formats:

[+-]dddd
	GMT[+-]d+
	[+-]dddd (TZN)
	TZN

=head2 Special formats:

[ d]d/Mon/yyyy:hh:mm:ss [[+-]dddd]
	yy/mm/dd.hh:mm

=head1 DESCRIPTION

This module recognizes the above date/time formats.   Usually a
date and a time are specified.  There are numerous options for 
controlling what is recognized and what is not.

The return code is always the time in seconds since January 1st, 1970
or undef if it was unable to parse the time.

If a timezone is specified it must be after the time.  Year specifications
can be tacked onto the end of absolute times.

If C<parsedate()> is called from array context, then it will return two
elements.  On successful parses, it will return the seconds and what 
remains of its input string.  On unsuccessful parses, it will return
C<undef> and an error string.

=head1 EXAMPLES

$seconds = parsedate("Mon Jan  2 04:24:27 1995");
	$seconds = parsedate("Tue Apr 4 00:22:12 PDT 1995");
	$seconds = parsedate("04.04.95 00:22", ZONE => PDT);
	$seconds = parsedate("Jan 1 1999 11:23:34.578", SUBSECOND => 1);
	$seconds = parsedate("122212 950404", ZONE => PDT, TIMEFIRST => 1);
	$seconds = parsedate("+3 secs", NOW => 796978800);
	$seconds = parsedate("2 months", NOW => 796720932);
	$seconds = parsedate("last Tuesday");
	$seconds = parsedate("Sunday before last");

($seconds, $remaining) = parsedate("today is the day");
	($seconds, $error) = parsedate("today is", WHOLE=>1);

=head1 LICENSE

Copyright (C) 1996-2010 David Muir Sharnoff.  
Copyright (C) 2011 Google, Inc.  
License hereby
granted for anyone to use, modify or redistribute this module at
their own risk.  Please feed useful changes back to cpan@dave.sharnoff.org.

${this.title}

Code Editor : ParseDate.pm