#/bin/sh
#In a recent posting someone was looking for perl routines that
#manipulate dates. Here's a perl library that implements the standard
#jday and jdate functions (as described in Collected Algorithms of
#the ACM). There are also routines which return the month name and
#weekday name given a month number of weekday number. And there are routines
#that return the Julian day number for today, tomorrow and yesterday.
#
#As a bonus prize, you also get an RPN-style date calculator. Similar to bc,
#it also allows you to push perl expressions onto the stack -- thanks to
#the magic of `eval'. Moreover, your expression can contain dates (like
#Jan 1, 1991) or functions like `today', `tomorrow' or `yesterday'.
#
#Just cut everything below the cut line and feed it to sh. You'll get
#date.pl (the subroutine library) and dtc (the calculator). You'll
#probably want to edit the first line of dtc.
#
#I would have like to have included routines that scan for any date format
#and extract it, but I haven't gotten around to it yet. Consequently, dtc
#supports only a few date formats. Sorry, but what's here is useful enough.
#
#Disclaimer: no warranty is expressed or implied
#
#Right to copy: you can do anything you want with this (but if you make
# lots of money from it, send me some)
#
#------------------------ cut line ------------------------------------
#/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# date.pl
# dtc
# This archive created: Wed Feb 6 23:45:04 1991
# By: Gary Puckering ()
export PATH; PATH=/bin:$PATH
if test -f 'date.pl'
then
echo shar: over-writing existing file "'date.pl'"
fi
cat << \SHAR_EOF > 'date.pl'
package date;
# The following defines the first day that the Gregorian calendar was used
# in the British Empire (Sep 14, 1752). The previous day was Sep 2, 1752
# by the Julian Calendar. The year began at March 25th before this date.
$brit_jd = 2361222;
sub main'jdate
# Usage: ($month,$day,$year,$weekday) = &jdate($julian_day)
{
local($jd) = @_;
local($jdate_tmp);
local($m,$d,$y,$wkday);
warn("warning: pre-dates British use of Gregorian calendar\n")
if ($jd < $brit_jd);
$wkday = ($jd + 1) % 7; # calculate weekday (0=Sun,6=Sat)
$jdate_tmp = $jd - 1721119;
$y = int((4 * $jdate_tmp - 1)/146097);
$jdate_tmp = 4 * $jdate_tmp - 1 - 146097 * $y;
$d = int($jdate_tmp/4);
$jdate_tmp = int((4 * $d + 3)/1461);
$d = 4 * $d + 3 - 1461 * $jdate_tmp;
$d = int(($d + 4)/4);
$m = int((5 * $d - 3)/153);
$d = 5 * $d - 3 - 153 * $m;
$d = int(($d + 5) / 5);
$y = 100 * $y + $jdate_tmp;
if($m < 10) {
$m += 3;
} else {
$m -= 9;
++$y;
}
($m, $d, $y, $wkday);
}
sub main'jday
# Usage: $julian_day = &jday($month,$day,$year)
{
local($m,$d,$y) = @_;
local($ya,$c);
$y = (localtime(time))[5] + 1900 if ($y eq '');
if ($m > 2) {
$m -= 3;
} else {
$m += 9;
--$y;
}
$c = int($y/100);
$ya = $y - (100 * $c);
$jd = int((146097 * $c) / 4) +
int((1461 * $ya) / 4) +
int((153 * $m + 2) / 5) +
$d + 1721119;
warn("warning: pre-dates British use of Gregorian calendar\n")
if ($jd < $brit_jd);
$jd;
}
sub main'is_jday
{
# Usage: if (&is_jday($number)) { print "yep - looks like a jday"; }
local($is_jday) = 0;
$is_jday = 1 if ($_[0] > 1721119);
}
sub main'monthname
# Usage: $month_name = &monthname($month_no)
{
local($n,$m) = @_;
local(@names) = ('January','February','March','April','May','June',
'July','August','September','October','November',
'December');
if ($m ne '') {
substr($names[$n-1],0,$m);
} else {
$names[$n-1];
}
}
sub main'monthnum
# Usage: $month_number = &monthnum($month_name)
{
local($name) = @_;
local(%names) = (
'JAN',1,'FEB',2,'MAR',3,'APR',4,'MAY',5,'JUN',6,'JUL',7,'AUG',8,
'SEP',9,'OCT',10,'NOV',11,'DEC',12);
$name =~ tr/a-z/A-Z/;
$name = substr($name,0,3);
$names{$name};
}
sub main'weekday
# Usage: $weekday_name = &weekday($weekday_number)
{
local($wd) = @_;
("Sun","Mon","Tue","Wed","Thu","Fri","Sat")[$wd];
}
sub main'today
# Usage: $today_julian_day = &today()
{
local(@today) = localtime(time);
local($d) = $today[3];
local($m) = $today[4];
local($y) = $today[5];
$m += 1;
$y += 1900;
&main'jday($m,$d,$y);
}
sub main'yesterday
# Usage: $yesterday_julian_day = &yesterday()
{
&main'today() - 1;
}
sub main'tomorrow
# Usage: $tomorrow_julian_day = &tomorrow()
{
&main'today() + 1;
}
SHAR_EOF
if test -f 'dtc'
then
echo shar: over-writing existing file "'dtc'"
fi
cat << \SHAR_EOF > 'dtc'
#/usr/local/bin/perl -I/home/garyp/perl
require 'date.pl';
$command = '';
print " Date Calculator version 1.0\n";
print " (type `h' for help)\n";
print "> ";
while(<stdin>) {
($command) = /^\s*(\w+)\s*$/;
last if (index("quit",$command) == 0);
if (/^\s*(\d+)\s+(\d+)\s+(\d+)\s*$/) { # quit
$j = &jday($1,$2,$3);
push(@stack,$j);
next;
}
elsif (/^\s*(\w+)\s+(\d+)(\s+(\d+)?)\s*$/) { # mmm dd yy
# assumes this year if year is missing
$j = &jday(&monthnum($1),$2,$4);
push(@stack,$j);
next;
}
elsif (/^\s*([-]?\d+)\s*$/) { # [-]n
push(@stack,$1);
next;
}
elsif (index("clear",$command)==0) { # clear
@stack = ();
next;
}
elsif (index("duplicate",$command)==0) { # duplicate
push(@stack,$stack[$#stack]);
next;
}
elsif (index("exchange",$command)==0 ||
$command eq 'x') { # exchange
$x = pop(@stack);
$y = pop(@stack);
push(@stack,$x);
push(@stack,$y);
next;
}
elsif (index("print",$command)==0) { # print
do print($stack[$#stack]);
next;
}
elsif (index("today",$command)==0) { # today
push(@stack,&today());
do print($stack[$#stack]);
next;
}
elsif (/^\s*[+]\s*$/) { # add
$y = pop(@stack);
$x = pop(@stack);
if (&is_jday($x) && &is_jday($y)) {
print stderr "** cannot add two dates\n";
push(@stack,$x);
push(@stack,$y);
next;
}
$r = $x + $y;
push(@stack,$r);
do print($r);
next;
}
elsif (m:^\s*([\-*/%])\s*$:) { # (-) (*) (/) and (%)
$y = pop(@stack);
$x = pop(@stack);
$r = eval "$x $+ $y";
warn "** evaluation error $@\n" if $@ ne "";
push(@stack,$r);
do print($r);
next;
}
elsif (index("Print",$command)==0) { # dump
do dump();
next;
}
elsif (index("help",$command)==0) { # help
print <<EOD ;
Commands:
mmm dd Push date for current year onto stack
mmm dd yyyy Push date onto stack
n or -n Push positive/negative constant or interval onto stack
+ - * / % Add, subtract, multiply, divide, modulo
expr Push result of Perl expression onto stack
<d>uplicate Push a duplicate of the top value onto the stack
<c>lear Clear stack
<p>rint Print last value on stack
<P>rint Print all stack values
<t>oday Put today's date on the stack
e<x>change Exchange top two values of stack
<q>uit Exit the program
Note: expressions are scanned for embedded dates of the form `1991/Jan/2',
`Jan 1, 1991' or just `Jan 1'. These dates are translated to Julian
Day numbers before the expression is evaluated. Also, the tokens
`today', `tomorrow' and `yesterday' are replaced with their
respective Julian Day numbers. If the expression does something
stupid with Julian Day numbers (like add them) you get silly
results.
EOD
next;
}
else {
chop;
# replace yyyy/mmm/dd dates with Julian day number
s|(\d{1,4})\W?(\w\w\w)\W?(\d\d?)|&jday(&monthnum($2),$3,$1)|ge;
# replace mmm dd yyyy dates with Julian day number
s|(\w\w\w)[\W\s](\d\d?)[,]?[\W\s](\d{1,4})|&jday(&monthnum($1),$2,$3)|ge;
# replace mmm dd dates with Julian day number (for this year)
s|(\w\w\w)[\W\s](\d\d?)|&jday(&monthnum($1),$2)|ge;
# replace 'today' with todays jday
s|\b(today)\b|&today()|ge;
# replace 'tomorrow' with tomorrows jday
s|\b(tomorrow)\b|&tomorrow()|ge;
# replace 'yesterday' with yesterdays jday
s|\b(yesterday)\b|&yesterday()|ge;
print $_,"\n";
push(@stack,eval($_));
do print($stack[$#stack]);
next;
}
# else { warn "** invalid command - try \"help\"\n" unless ($_ eq "\n"); }
} continue {
print "> ";
$command = "";
}
sub print #(value)
{
if (&is_jday($_[0])) {
($m,$d,$y,$wd) = &jdate($_[0]);
$month = &monthname($m,3);
$wkday = &weekday($wd);
print "= $wkday $month $d, $y (JD = $_[0])\n";
} else {
if ($_[0] > 365 || $_[0] < -365) {
$years = int($_[0] / 365.25);
$days = $_[0] - int($years * 365.25);
print "= $_[0] days ($years years, $days days)\n\n";
} else {
print "= $_[0] days\n\n";
}
}
}
sub dump
{
for ($i = 0; $i <= $#stack; $i++) {
print "stack[",$i,"] ";
do print($stack[$i]);
}
}
SHAR_EOF
chmod +x 'dtc'
# End of shell archive
exit 0
--
Gary Puckering Cognos Incorporated
VOICE: (613) 738-1338 x6100 P.O. Box 9707
UUCP: uunet!mitel!cunews!cognos!garyp Ottawa, Ontario
INET: garyp%
[email protected] CANADA K1G 3Z4
