terry@geovision.gvc.com (Terry McGonigal) (03/23/91)
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