;#
;# Name
;#	date.pl - Perl emulation of (the output side of) date(1)
;#
;# Synopsis
;#	require "date.pl";
;#	$Date = &date(time);
;#	$Date = &date(time, $format);
;#
;# Description
;#	This package implements the output formatting functions of date(1) in
;#	Perl.  The format options are based on those supported by Ultrix 4.0
;#	plus a couple of additions from SunOS 4.1.1 and elsewhere:
;#
;#		%a		abbreviated weekday name - Sun to Sat
;#		%A		full weekday name - Sunday to Saturday
;#		%b		abbreviated month name - Jan to Dec
;#		%B		full month name - January to December
;#		%c		date and time in local format [+]
;#		%C		date and time in long local format [+]
;#		%d		day of month - 01 to 31
;#		%D		date as mm/dd/yy
;#		%e		day of month (space padded) - ` 1' to `31'
;#		%E		day of month (with suffix: 1st, 2nd, 3rd...)
;#		%f		month of year (space padded) - ` 1' to `12'
;#		%h		abbreviated month name - Jan to Dec
;#		%H		hour - 00 to 23
;#		%i		hour (space padded) - ` 1' to `12'
;#		%I		hour - 01 to 12
;#		%j		day of the year (Julian date) - 001 to 366
;#		%k		hour (space padded) - ` 0' to `23'
;#		%l		date in ls(1) format
;#		%m		month of year - 01 to 12
;#		%M		minute - 00 to 59
;#		%n		insert a newline character
;#		%p		ante-meridiem or post-meridiem indicator (AM or PM)
;#		%r		time in AM/PM notation
;#		%R		time as HH:MM
;#		%S		second - 00 to 59
;#		%t		insert a tab character
;#		%T		time as HH:MM:SS
;#		%u		date/time in date(1) required format
;#		%U		week number, Sunday as first day of week - 00 to 53
;#		%V		date-time in SysV touch format (mmddHHMMyy)
;#		%w		day of week - 0 (Sunday) to 6
;#		%W		week number, Monday as first day of week - 00 to 53
;#		%x		date in local format [+]
;#		%X		time in local format [+]
;#		%y		last 2 digits of year - 00 to 99
;#		%Y		all 4 digits of year ~ 1700 to 2000 odd ?
;#		%z		time zone from TZ environment variable w/ a trailing space
;#		%Z		time zone from TZ environment variable
;#		%%		insert a `%' character
;#		%+		insert a `+' character
;#
;#	[+]:  These may need adjustment to fit local conventions, see below.
;#
;#	For the sake of compatibility, a leading `+' in the format
;#	specificaiton is removed if present.
;#
;# Remarks
;#	This is version 3.4 of date.pl
;#
;#	An extension of `ctime.pl' by Waldemar Kebsch (kebsch.pad@nixpbe.UUCP),
;#	as modified by Marion Hakanson (hakanson@ogicse.ogi.edu).
;#
;#  Unlike date(1), unknown format tags are silently replaced by "".
;#
;#  defaultTZ is a blatant hack, but I wanted to be able to get date(1)
;#	like behaviour by default and there does'nt seem to be an easy (read
;#	portable) way to get the local TZ name back...
;#
;#	For a cheap date, try...
;#
;#		#!/usr/local/bin/perl
;#		require "date.pl";
;#		exit print (&date(time, shift @ARGV) . "\n") ? 0 : 1;
;#
;#	This package is redistributable under the same terms as apply to
;#	the Perl 4.0 release.  See the COPYING file in your Perl kit for
;#	more information.
;#
;#	Please send any bug reports or comments to tmcgonigal@gallium.com
;#
;# Modification History
;#	Nmemonic	Version	Date		Who
;#
;#	NONE		1.0		02feb91		Terry McGonigal (tmcgonigal@gallium.com)
;#		Created from ctime.pl
;#
;#	NONE		2.0		07feb91		tmcgonigal
;#		Added some of Marion Hakanson (hakanson@ogicse.ogi.edu)'s ctime.pl
;#		TZ handling changes.
;#
;#	NONE		2.1		09feb91		tmcgonigal
;#		Corrected week number calculations.
;#
;#	NONE		2.2		21oct91		tmcgonigal
;#		Added ls(1) date format, `%l'.
;#
;#	NONE		2.3		06nov91		tmcgonigal
;#		Added SysV touch(1) date-time format, `%V' (pretty thin as
;#		mnemonics go, I know, but `t' and `T' were both gone already!)
;#
;#	NONE		2.4		05jan92		tmcgonigal
;#		Corrected slight (cosmetic) problem with %V replacment string
;#
;#	NONE		3.0		09jul92		tmcgonigal
;#		Fixed a couple of problems with &ls as pointed out by
;#		Thomas Richter (richter@ki1.chemie.fu-berlin.de), thanks Thomas!
;#		Also added a couple of SunOS 4.1.1 strftime-ish formats, %i and %k
;#		for space padded hours (` 1' to `12' and ` 0' to `23' respectivly),
;#		and %C for locale long date/time format.  Changed &ampmH to take a
;#		pad char parameter to make to evaled code for %i and %k simpler. 
;#		Added %E for suffixed day-of-month (ie 1st, 3rd, 4th etc).
;#
;#	NONE		3.1		16jul92		tmcgonigal
;#		Added `%u' format to generate date/time in date(1) required
;#		format (ie '%y%m%d%H%M.%S').
;#
;#	NONE		3.2		23jan93		tmcgonigal
;#		Added `%f' format to generate space padded month numbers, added
;#		`%E' to the header comments, it seems to have been left out (and
;#		I'm sure I wanted to use it at some point in the past...).
;#
;#	NONE		3.3		03feb93		tmcgonigal
;#		Corrected some problems with AM/PM handling pointed out by
;#		Michael S. Muegel (mmuegel@mot.com).  Thanks Michael, I hope
;#		this is the behaviour you were looking for, it seems more
;#		correct to me...
;#
;#	NONE		3.4		26jul93		tmcgonigal
;#		Incorporated some fixes provided by DaviD W. Sanderson
;#		(dws@ssec.wisc.edu): February was spelled incorrectly and
;#		&wkno() was always using the current year while calculating
;#		week numbers, regardless of year implied by the time value
;#		passed to &date().  DaviD also contributed an improved &date()
;#		test script, thanks DaviD, I appreciate the effort.  Finally,
;#		changed my mailling address from @gvc.com to @gallium.com
;#		to reflect, well, my new address!
;#
;# SccsId = "%W% %E%"
;#
require 'timelocal.pl';
package date;

# Months of the year
@MoY = ('January',	'February',	'March',	'April',	'May',		'June',
		'July',		'August',	'September','October',	'November', 'December');

# days of the week
@DoW = ('Sunday',	'Monday',	'Tuesday',	'Wednesday',
		'Thursday',	'Friday',	'Saturday');

# CUSTOMIZE - defaults
$defaultTZ = 'CST';						# time zone (hack!)
$defaultFMT = '%a %h %e %T %z%Y';		# format (ala date(1))

# CUSTOMIZE - `local' formats
$locTF = '%T';							# time (as HH:MM:SS)
$locDF = '%D';							# date (as mm/dd/yy)
$locDTF = '%a %b %d %T %Y';				# date/time (as dow mon dd HH:MM:SS yyyy)
$locLDTF = '%i:%M:%S %p %A %B %E %Y';	# long date/time (as HH:MM:SS a/p day month dom yyyy)

# Time zone info
$TZ;									# wkno needs this info too

# define the known format tags as associative keys with their associated
# replacement strings as values.  Each replacement string should be
# an eval-able expresion assigning a value to $rep.  These expressions are
# eval-ed, then the value of $rep is substituted into the supplied
# format (if any).
%Tags = ( '%a', q|($rep = $DoW[$wday])=~ s/^(...).*/\1/|,	# abbr. weekday name - Sun to Sat
		  '%A', q|$rep = $DoW[$wday]|,						# full weekday name - Sunday to Saturday
		  '%b', q|($rep = $MoY[$mon]) =~ s/^(...).*/\1/|,	# abbr. month name - Jan to Dec
		  '%B', q|$rep = $MoY[$mon]|,						# full month name - January to December
		  '%c', q|$rep = $locDTF; 1|,						# date/time in local format
		  '%C', q|$rep = $locLDTF; 1|,						# date/time in local long format
		  '%d',	q|$rep = &date'pad($mday, 2, "0")|,			# day of month - 01 to 31
		  '%D',	q|$rep = '%m/%d/%y'|,						# date as mm/dd/yy
		  '%e', q|$rep = &date'pad($mday, 2, " ")|,			# day of month (space padded) ` 1' to `31'
		  '%E', q|$rep = &date'dsuf($mday)|,				# day of month (w/suffix) `1st' to `31st'
		  '%f', q|$rep = &date'pad($mon+1, 2, " ")|,		# month of year (space padded) ` 1' to `12'
		  '%h', q|$rep = '%b'|,								# abbr. month name (same as %b)
		  '%H',	q|$rep = &date'pad($hour, 2, "0")|,			# hour - 00 to 23
		  '%i', q|$rep = &date'ampmH($hour, " ")|,			# hour (space padded ` 1' to `12'
		  '%I', q|$rep = &date'ampmH($hour, "0")|,			# hour - 01 to 12
		  '%j', q|$rep = &date'pad($yday+1, 3, "0")|,		# Julian date 001 - 366
		  '%k', q|$rep = &date'pad($hour, 2, " ")|,			# hour (space padded) ` 0' to `23'
		  '%l', q|$rep = '%b %d ' . &date'ls($year)|,		# ls(1) style date
		  '%m',	q|$rep = &date'pad($mon+1, 2, "0")|,		# month of year - 01 to 12
		  '%M', q|$rep = &date'pad($min, 2, "0")|,			# minute - 00 to 59
		  '%n',	q|$rep = "\n"|,								# insert a newline
		  '%p', q|$rep = &date'ampmD($hour)|,				# insert `AM' or `PM'
		  '%r', q|$rep = '%I:%M:%S %p'|,					# time in AM/PM notation
		  '%R', q|$rep = '%H:%M'|,							# time as HH:MM
		  '%S', q|$rep = &date'pad($sec, 2, "0")|,			# second - 00 to 59
		  '%t',	q|$rep = "\t"|,								# insert a tab
		  '%T',	q|$rep = '%H:%M:%S'|,						# time as HH:MM:SS
		  '%u', q|$rep = '%y%m%d%H%M.%S'|,					# daaate/time in date(1) required format
		  '%U',	q|$rep = &date'wkno($year, $yday, 0)|,		# week number (weeks start on Sun) - 00 to 53
		  '%V', q|$rep = '%m%d%H%M%y'|,						# SysV touch(1) date-time format (mmddHHMMyy)
		  '%w', q|$rep = $wday; 1|,							# day of week - Sunday = 0
		  '%W', q|$rep = &date'wkno($year, $yday, 1)|,		# week number (weeks start on Mon) - 00 to 53
		  '%x', q|$rep = $locDF; 1|,						# date in local format
		  '%X', q|$rep = $locTF; 1|,						# time in local format
		  '%y', q|($rep = $year) =~ s/..(..)/\1/|,			# last 2 digits of year - 00 to 99
		  '%Y', q|$rep = "$year"; 1|,						# full year ~ 1700 to 2000 odd
		  '%z', q|$rep = $TZ eq "" ? "" : "$TZ "|,			# time zone from TZ env var (w/trail. space)
		  '%Z', q|$rep = $TZ; 1|,							# time zone from TZ env. var.
		  '%%', q|$rep = '%'; $adv=1|,						# insert a `%'
		  '%+', q|$rep = '+'|								# insert a `+'
);
	
sub main'date {
	local($time, $format) = @_;
	local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
	local($pos, $tag, $rep, $adv) = (0, "", "", 0);

	# default to date/ctime format or strip leading `+'...
	if ($format eq "") {
		$format = $defaultFMT;
	} elsif ($format =~ /^\+/) {
		$format = $';
	}

	# Use local time if can't find a TZ in the environment
	$TZ = defined($ENV{'TZ'}) ? $ENV{'TZ'} : $defaultTZ;
	($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = 
		&gettime ($TZ, $time);

	# Hack to deal with 'PST8PDT' format of TZ
	# Note that this can't deal with all the esoteric forms, but it
	# does recognize the most common: [:]STDoff[DST[off][,rule]]
	if ($TZ =~ /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/) {
		$TZ = $isdst ? $4 : $1;
	}

	# watch out in 2070...
	$year += ($year < 70) ? 2000 : 1900;

	# now loop throught the supplied format looking for tags...
	while (($pos = index ($format, '%')) != -1) {

		# grab the format tag
		$tag = substr($format, $pos, 2);
		$adv = 0;							# for `%%' processing

		# do we have a replacement string?
		if (defined $Tags{$tag}) {

			# trap dead evals...
			if (! eval $Tags{$tag}) {
				print STDERR "date.pl: internal error: eval for $tag failed: $@\n";
				return "";
			}
		} else {
			$rep = "";
		}
			
		# do the substitution
		substr ($format, $pos, 2) =~ s/$tag/$rep/;
		$pos++ if ($adv);
	}

	$format;
}

# dsuf - add `st', `nd', `rd', `th' to a date (ie 1st, 22nd, 29th)
sub dsuf {
	local ($mday) = @_;

	return $mday . 'st' if ($mday =~ m/.*1$/);
	return $mday . 'nd' if ($mday =~ m/.*2$/);
	return $mday . 'rd' if ($mday =~ m/.*3$/);
	return $mday . 'th';
}
	
# weekno - figure out week number
sub wkno {
	local ($year, $yday, $firstweekday) = @_;   
	local ($jan1, @jan1, $wks);

	# figure out the `time' value for January 1 of the given year
	$jan1 = &maketime ($TZ, 0, 0, 0, 1, 0, $year-1900);

	# figure out what day of the week January 1 was
	@jan1= &gettime ($TZ, $jan1);
	
	# and calculate the week number
	$wks = (($yday + ($jan1[6] - $firstweekday)) + 1)/ 7;
	$wks += (($wks - int($wks) > 0.0) ? 1 : 0);

	# supply zero padding
	&pad (int($wks), 2, "0");
}

# ampmH - figure out am/pm (1 - 12) mode hour value, padded with $p (0 or ' ')
sub ampmH { local ($h, $p) = @_;  &pad($h>12 ? $h-12 : ($h ? $h : 12), 2, $p); }

# ampmD - figure out am/pm designator
sub ampmD { shift @_ >= 12 ? "PM" : "AM"; }

# gettime - get the time via {local,gmt}time
sub gettime { ((shift @_) eq 'GMT') ? gmtime(shift @_) : localtime(shift @_); }

# maketime - make a time via time{local,gmt}
sub maketime { ((shift @_) eq 'GMT') ? &main'timegm(@_) : &main'timelocal(@_); }

# ls - generate the time/year portion of an ls(1) style date
sub ls {
	return ((&gettime ($TZ, time))[5] == @_[0]) ? "%R" : " %Y";
}

# pad - pad $in with leading $pad until lenght $len
sub pad {
	local ($in, $len, $pad) = @_;
	local ($out) = "$in";

	$out = $pad . $out until (length ($out) == $len);
	return $out;
}

1;