InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/perl/scripts-osu/date.shar

Text File | 1991-02-10 | 9.3 KB | 353 lines

Path: tut.cis.ohio-state.edu!zaphod.mps.ohio-state.edu!uakari.primate.wisc.edu!dali.cs.montana.edu!milton!uw-beaver!ubc-cs!news-server.csri.toronto.edu!utgpu!cunews!cognos!garyp
From: [e-mail] (Gary Puckering)
Newsgroups: comp.lang.perl
Subject: Date subroutines and calculator
Message-ID: <[e-mail]>
Date: 7 Feb 91 04:58:10 GMT
Reply-To: [e-mail] (Gary Puckering)
Organization: Cognos Inc., Ottawa, Canada
Lines: 341

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: [phone] x6100              P.O. Box 9707
  UUCP:  uunet!mitel!cunews!cognos!garyp   Ottawa, Ontario
  INET:  [e-mail]    CANADA  K1G 3Z4