File Coverage

blib/lib/Time/ParseDate.pm

Criterion	Covered	Total	%
statement	413	459	89.9
branch	345	494	69.8
condition	165	238	69.3
subroutine	20	21	95.2
pod	0	13	0.0
total	943	1225	76.9

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 = 2013.1113;

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