Path: utzoo!utgpu!cunews!cognos!geovision!terry
From: terry@geovision.gvc.com (Terry McGonigal)
Newsgroups: comp.lang.perl
Subject: Perl date(1) emulator
Keywords: date, time
Message-ID: <1458@geovision.gvc.com>
Date: 22 Mar 91 16:19:18 GMT
Organization: GeoVision Corp., Ottawa, Ont, Canada
Lines: 383

G'Day...

I've been a lurker here in c.l.p for quite a while now, stashing away the
various bits of code and advice that go by, and recently noticed a wish
for a time.pl.  While I'm not sure quite what the original wisher was
looking for, what follows is a date(1) emulator I've been using for a while
here, based on `ctime.pl' by Waldemar Kebsch (kebsch.pad@nixpbe.UUCP), as
modified by Marion Hakanson (hakanson@ogicse.ogi.edu) and extended by yours
truly.

This is one of my first bits of Perl that have felt really Perl-ish when
finished.  Most of my other  efforts have a more csh/sh/C feel to them, but
this is different!  My favorite moment in this stuff has got to be:

		substr ($format, $pos, 2) =~ s/$tag/$rep/;

Which does a reg-exp substitution in-place on the supplied date format. It's
a bit scary to think of the code required to express this in C but here
(in Perl) it's a single line. I thought that the %array of format tags and
eval-able code was pretty Perly too...  The second file in the following shar
is a very simple set of tests for date.pl.  There is no man page, but date.pl
has a long introductory header section that should make using it pretty
obivious, and (at least some) comments through out the body of the code.

It's nice to have a 4GL handy, many thanks Larry, the same for Randal,
Tom C., and all the rest who've made switching from csh/sh/C as easy as it
has been ('though I'm still looking forward to a copy of *The Book* :).

Cheers,
--
Terry McGonigal    GeoVision Corp   {uunet,cunews!cognos}!geovision!terry
                   Ottawa On, Can   tmcgonigal@gvc.com
                   613-722-9518

[ Please excuse the verbosity of my shar-er, it's home grown... ]
[ There may also be a second .sig somewhere down there... ]
>>------------------------------C U T  H E R E----------------------------<<
#!/bin/sh
# This is a shell archive.  Remove anything before these lines,
# then unpack it by saving it into a file and typing "sh file".
# To overwrite existing files, type "sh file -c".  You can get
# a listing of the archive contents with "sh file -l".
# If this archive is complete you will see the following message
# when the extraction process is complete:
#      "End of shell archive."
#
# Created by terry@geovision on Fri Mar 22 10:46:46 EST 1991
PATH=/bin:/usr/bin:/usr/ucb; export PATH
overWrite=false                # default to not over-writing files
listOnly=false                 # default extracting files
restoreOwner=false             # default to extractor
while [ $# -gt 0 ]; do
  case $1 in
    -c)	overWrite=true;;     # over-write existing files
    -l)   listOnly=true;;      # just list the archive contents
    -p)   restoreOwner=true;;  # restore file ownerships
    -*)   echo "unshar: Unkown switch \"$1\" ignored.";;
     *)   break;;
  esac;
  shift;
done
if [ $restoreOwner = true -a `whoami` != root ]; then
  echo unshar: Only root can use the -p switch, ignored.
  restoreOwner=false
fi
if [ $listOnly = true ]; then
  echo unshar: Archive Contents:
fi
# <File date.pl>
if [ $listOnly = true ]; then
  echo "-rw-rw-rw-  1 terry        8535 Feb 13 15:45 date.pl"
elif [ -f date.pl -a $overWrite != true ]; then
  echo unshar: Will not over-write existing file \"date.pl\".
else
  echo unshar: Extracting \"date.pl\" \(     8535 characters \)
  sed "s/^X//" >date.pl <<'_END_OF_date.pl_'
X;#
X;# Name
X;#	date.pl - Perl emulation of (the output side of) date(1)
X;#
X;# Synopsis
X;#	requirelude "date.pl";
X;#	$Date = &date(time);
X;#	$Date = &date(time, $format);
X;#
X;# Description
X;#	This package implements the output formatting functions of date(1) in
X;#	Perl.  The format options are based on those supported by Ultrix 4.0
X;#	plus a couple of additions:
X;#
X;#		%a		abbreviated weekday name - Sun to Sat
X;#		%A		full weekday name - Sunday to Saturday
X;#		%b		abbreviated month name - Jan to Dec
X;#		%B		full month name - January to December
X;#		%c		date and time in local format [+]
X;#		%d		day of month - 01 to 31
X;#		%D		date as mm/dd/yy
X;#		%e		day of month (space padded) - ` 1' to `31'
X;#		%h		abbreviated month name - Jan to Dec
X;#		%H		hour - 00 to 23
X;#		%I		hour - 01 to 12
X;#		%j		day of the year (Julian date) - 001 to 366
X;#		%m		month of year - 01 to 12
X;#		%M		minute - 00 to 59
X;#		%n		insert a newline character
X;#		%p		AM or PM
X;#		%r		time in AM/PM notation
X;#		%R		time as HH:MM
X;#		%S		second - 00 to 59
X;#		%t		insert a tab character
X;#		%T		time as HH:MM:SS
X;#		%U		week number, Sunday as first day of week - 00 to 53
X;#		%w		day of week - 0 (Sunday) to 6
X;#		%W		week number, Monday as first day of week - 00 to 53
X;#		%x		date in local format [+]
X;#		%X		time in local format [+]
X;#		%y		last 2 digits of year - 00 to 99
X;#		%Y		all 4 digits of year ~ 1700 to 2000 odd ?
X;#		%z		time zone from TZ environment variable w/ a trailing space [*]
X;#		%Z		time zone from TZ environment variable
X;#		%%		insert a `%' character
X;#		%+		insert a `+' character [*]
X;#
X;#	[*]:  Not supported by date(1) but I wanted 'em.
X;#	[+]:  These may need adjustment to fit local conventions, see below.
X;#
X;#	For the sake of compatibility, a leading `+' in the format
X;#	specificaiton is removed if present.
X;#
X;# Remarks
X;#	An extension of `ctime.pl' by Waldemar Kebsch (kebsch.pad@nixpbe.UUCP),
X;#	as modified by Marion Hakanson (hakanson@ogicse.ogi.edu).
X;#
X;#  Unlike date(1), unknown format tags are silently replaced by "".
X;#
X;#  defaultTZ is a blatant hack, but I wanted to be able to get date(1)
X;#	like behaviour by default and there does'nt seem to be an easy (read
X;#	portable) way to get the local TZ name back...
X;#
X;#	For a cheap date, try...
X;#
X;#		#!/usr/local/bin/perl
X;#		require "date.pl";
X;#		exit print (&date(time, shift @ARGV) . "\n") ? 0 : 1;
X;#
X;#	This package is redistributable under the same terms as apply to
X;#	the Perl 3.0 release.  See the COPYING file in your Perl kit for
X;#	more information.
X;#
X;#	Please send any bug reports or comments to tmcgonigal@gvc.com
X;#
X;# Modification History
X;#	Nmemonic	Version	Date		Who
X;#
X;#	NONE		none	02feb91		Terry McGonigal (tmcgonigal@gvc.com)
X;#		Created from ctime.pl
X;#
X;#	NONE		none	07feb91		tmcgonigal
X;#		Added some of Marion Hakanson (hakanson@ogicse.ogi.edu)'s ctime.pl
X;#		TZ handling changes.
X;#
X;#	NONE		none	09feb91		tmcgonigal
X;#		Corrected week number calculations.
X;#
X;# SccsId = "%W% %E%"
X;#
Xpackage date;
X
X# Months of the year
X@MoY = ('January',	'Febuary',	'March',	'April',	'May',		'June',
X		'July',		'August',	'September','October',	'November', 'December');
X
X# days of the week
X@DoW = ('Sunday',	'Monday',	'Tuesday',	'Wednesday',
X		'Thursday',	'Friday',	'Saturday');
X
X# defaults
X$defaultTZ = 'EST';					# time zone (hack!)
X$defaultFMT = '%a %h %e %T %z%Y';	# format (ala date(1))
X
X# `local' formats
X$locTF = '%T';						# time (as HH:MM:SS)
X$locDF = '%D';						# date (as mm/dd/yy)
X$locDTF = '%a %b %d %T %Y';			# date/time (as dow mon dd HH:MM:SS yyy)
X
X# Time zone info
X$TZ;								# wkno needs this info too
X
X# define the known format tags as associative keys with their associated
X# replacement strings as values.  Each replacement string should be
X# an eval-able expresion assigning a value to $rep.  These expressions are
X# eval-ed, then the value of $rep is substituted into the supplied
X# format (if any).
X%Tags = ( '%a', '($rep = $DoW[$wday])=~ s/^(...).*/\1/',# abbr. weekday name - Sun to Sat
X		  '%A', '$rep = $DoW[$wday]',					# full weekday name - Sunday to Saturday
X		  '%b', '($rep = $MoY[$mon]) =~ s/^(...).*/\1/',# abbr. month name - Jan to Dec
X		  '%B', '$rep = $MoY[$mon]',					# full month name - January to December
X		  '%c', '$rep = $locDTF; 1',					# date/time in local format
X		  '%d',	'$rep = &date\'pad($mday, 2, "0")',		# day of month - 01 to 31
X		  '%D',	'$rep = \'%m/%d/%y\'',					# date as mm/dd/yy
X		  '%e', '$rep = &date\'pad($mday, 2, " ")',		# day of month (space padded) ` 1' to `31'
X		  '%h', '$rep = \'%b\'',						# abbr. month name (same as %b)
X		  '%H',	'$rep = &date\'pad($hour, 2, "0")',		# hour - 00 to 23
X		  '%I', '$rep = &date\'ampmH($hour)',			# hour - 01 to 12
X		  '%j', '$rep = &date\'pad($yday+1, 3, "0")',	# Julian date 001 - 366
X		  '%m',	'$rep = &date\'pad($mon+1, 2, "0")',	# month of year - 01 to 12
X		  '%M', '$rep = &date\'pad($min, 2, "0")',		# minute - 00 to 59
X		  '%n',	'$rep = "\n"',							# insert a newline
X		  '%p', '$rep = &date\'ampmD($hour)',			# insert `AM' or `PM'
X		  '%r', '$rep = \'%I:%M:%S %p\'',				# time in AM/PM notation
X		  '%R', '$rep = \'%H:%M\'',						# time as HH:MM
X		  '%S', '$rep = &date\'pad($sec, 2, "0")',		# second - 00 to 59
X		  '%t',	'$rep = "\t"',							# insert a tab
X		  '%T',	'$rep = \'%H:%M:%S\'',					# time as HH:MM:SS
X		  '%U',	'$rep = &date\'wkno($yday, 0)',			# week number (weeks start on Sun) - 00 to 53
X		  '%w', '$rep = $wday; 1',						# day of week - Sunday = 0
X		  '%W', '$rep = &date\'wkno($yday, 1)',			# week number (weeks start on Mon) - 00 to 53
X		  '%x', '$rep = $locDF; 1',						# date in local format
X		  '%X', '$rep = $locTF; 1',						# time in local format
X		  '%y', '($rep = "$year") =~ s/..(..)/\1/',		# last 2 digits of year - 00 to 99
X		  '%Y', '$rep = "$year"',						# full year ~ 1700 to 2000 odd
X		  '%z', '$rep = $TZ eq "" ? "" : "$TZ "',		# time zone from TZ env var (w/trail. space)
X		  '%Z', '$rep = $TZ; 1',						# time zone from TZ env. var.
X		  '%%', '$rep = \'%\'; $adv=1',					# insert a `%'
X		  '%+', '$rep = \'+\''							# insert a `+'
X);
X	
Xsub main'date {
X	local($time, $format) = @_;
X	local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
X	local($pos, $tag, $rep, $adv) = (0, "", "", 0);
X
X
X	# default to date/ctime format or strip leading `+'...
X	if ($format eq "") {
X		$format = $defaultFMT;
X	} elsif ($format =~ /^\+/) {
X		$format = $';
X	}
X
X	# Use local time if can't find a TZ in the environment
X	$TZ = defined($ENV{'TZ'}) ? $ENV{'TZ'} : $defaultTZ;
X	($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = 
X		&gettime ($TZ, $time);
X
X	# Hack to deal with 'PST8PDT' format of TZ
X	# Note that this can't deal with all the esoteric forms, but it
X	# does recognize the most common: [:]STDoff[DST[off][,rule]]
X	if ($TZ =~ /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/) {
X		$TZ = $isdst ? $4 : $1;
X	}
X
X	# watch out in 2070...
X	$year += ($year < 70) ? 2000 : 1900;
X
X	# now loop throught the supplied format looking for tags...
X	while (($pos = index ($format, '%')) != -1) {
X
X		# grab the format tag
X		$tag = substr($format, $pos, 2);
X		$adv = 0;							# for `%%' processing
X
X		# do we have a replacement string?
X		if (defined $Tags{$tag}) {
X
X			# trap dead evals...
X			if (! eval $Tags{$tag}) {
X				print STDERR "date.pl: internal error: eval for $tag failed.\n";
X				return "";
X			}
X		} else {
X			$rep = "";
X		}
X			
X		# do the substitution
X		substr ($format, $pos, 2) =~ s/$tag/$rep/;
X		$pos++ if ($adv);
X	}
X
X	$format;
X}
X
X# weekno - figure out week number
Xsub wkno {
X	local ($yday, $firstweekday) = @_;   
X	local ($jan1, @jan1, $wks);
X	local ($now) = time;
X
X	# figure out the `time' value for January 1
X	$jan1 = $now - ((&gettime ($TZ, $now))[7] * 86400);		# 86400 sec/day
X
X	# figure out what day of the week January 1 was
X	@jan1= &gettime ($TZ, $jan1);
X	
X	# and calculate the week number
X	$wks = (($yday + ($jan1[6] - $firstweekday)) + 1)/ 7;
X	$wks += (($wks - int($wks) > 0.0) ? 1 : 0);
X
X	# supply zero padding
X	&pad (int($wks), 2, "0");
X}
X
X# ampmH - figure out am/pm (1 - 12) mode hour value.
Xsub ampmH { local ($h) = @_;  &pad($h>12 ? $h-12 : $h, 2, "0"); }
X
X# ampmD - figure out am/pm designator
Xsub ampmD { shift @_ > 12 ? "PM" : "AM"; }
X
X# gettime - get the time via {local,gmt}time
Xsub gettime { ((shift @_) eq 'GMT') ? gmtime(shift @_) : localtime(shift @_); }
X
X# pad - pad $in with leading $pad until lenght $len
Xsub pad {
X	local ($in, $len, $pad) = @_;
X	local ($out) = "$in";
X
X	$out = $pad . $out until (length ($out) == $len);
X	return $out;
X}
X
X1;
_END_OF_date.pl_
  if [ ! -f date.pl ]; then
    echo unshar: \"date.pl\" not unpacked!
  else
    if [     8535 -ne `wc -c <date.pl` ]; then
      echo unshar: \"date.pl\" upacked with wrong size!
    fi
    chmod 000 date.pl; chmod u+rw,g+rw,o+rw date.pl
    if [ $restoreOwner = true ]; then
      /etc/chown terry date.pl
    fi
  fi
fi
# <File test>
if [ $listOnly = true ]; then
  echo "-rwxr-xr-x  1 terry        1010 Feb  9 18:28 test"
elif [ -f test -a $overWrite != true ]; then
  echo unshar: Will not over-write existing file \"test\".
else
  echo unshar: Extracting \"test\" \(     1010 characters \)
  sed "s/^X//" >test <<'_END_OF_test_'
X#!/usr/local/bin/perl
Xrequire "date.pl";
X
X$time = 666067395;
X
Xif (&date ($time) eq 'Fri Feb  8 21:43:15 EST 1991')
X	{ print "ok 1\n"; } else { print "not ok 1\n"; }
Xif (&date ($time, '%a %b %e %T %z%Y%n') eq "Fri Feb  8 21:43:15 EST 1991\n")
X	{ print "ok 2\n"; } else { print "not ok 2\n"; }
Xif (&date ($time, '%d/%m/%y%n') eq "08/02/91\n")
X	{ print "ok 3\n"; } else { print "not ok 3\n"; }
Xif (&date ($time, '+%T%t%D') eq "21:43:15\t02/08/91")
X	{ print "ok 4\n"; } else { print "not ok 4\n"; }
Xif (&date ($time, '%j,%w') eq '039,5')
X	{ print "ok 5\n"; } else { print "not ok 5\n"; }
Xif (&date ($time, '+%a %r') eq 'Fri 09:43:15 PM')
X	{ print "ok 6\n"; } else { print "not ok 6\n"; }
Xif (&date ($time, '%c%n') eq "Fri Feb 08 21:43:15 1991\n")
X	{ print "ok 7\n"; } else { print "not ok 7\n"; }
Xif (&date ($time, '%A (%a) %B (%h)') eq 'Friday (Fri) Febuary (Feb)')
X	{ print "ok 8\n"; } else { print "not ok 8\n"; }
Xif (&date ($time, '%U / %W') eq '06 / 06')
X	{ print "ok 9\n"; } else { print "not ok 9\n"; }
X
X1;
_END_OF_test_
  if [ ! -f test ]; then
    echo unshar: \"test\" not unpacked!
  else
    if [     1010 -ne `wc -c <test` ]; then
      echo unshar: \"test\" upacked with wrong size!
    fi
    chmod 000 test; chmod u+rwx,g+rx,o+rx test
    if [ $restoreOwner = true ]; then
      /etc/chown terry test
    fi
  fi
fi
# <End Of Archive>
echo unshar: End of shell archive.
exit 0