#!/usr/contrib/bin/perl -w
# This script prints a beautified weather forecast for Louisville.

# $Log: wea,v $
# Revision 1.26  1996/12/10 07:35:15  tjchol01
# First CGI version.
#
# Revision 1.25  1996/09/04 00:05:04  tjchol01
# Added SWSKY, removed leading dots.
#
# Revision 1.24  1996/08/07 13:41:17  tjchol01
# Correction to previous correction.
#
# Revision 1.23  1996/08/07 03:12:59  tjchol01
# Mandatory space between weekday and month for pollen date parsing.
#
# Revision 1.22  1996/07/11 02:30:17  tjchol01
# Added Fort Knox.  Corrected |$full| handling.
#
# Revision 1.21  1996/07/07 18:33:17  tjchol01
# Small changes in control and timeout.
#
# Revision 1.20  1996/07/03 13:46:15  tjchol01
# Added full path for lynx (for cron).
#
# Revision 1.19  1996/06/18 03:50:31  tjchol01
# Retries on fetching error.
#
# Revision 1.18  1996/06/12 14:20:17  tjchol01
# Added uspec to urls for current.
#
# Revision 1.17  1996/06/12 02:45:16  tjchol01
# Timeouts, AQI moved to current.
#
# Revision 1.16  1996/06/10 14:21:04  tjchol01
# Adaptive period.
#
# Revision 1.15  1996/06/08 23:14:15  tjchol01
# Experiment with line wrapping.
#
# Revision 1.14  1996/06/08 14:34:05  tjchol01
# Corrected pollen date parsing.
#
# Revision 1.13  1996/05/30 14:14:21  tjchol01
# Split products into current and noncurrent.  Corrected |$time| printing.
#
# Revision 1.12  1996/05/29 14:23:50  tjchol01
# Brian on recipients list, removed @uu, shift corrected, tput *,
# pollen flush, $^T, subject line.
#
# Revision 1.11  1996/05/29 05:10:47  tjchol01
# Added '-m' option for mailing list.
#
# Revision 1.10  1996/05/29 03:46:03  tjchol01
# More author removal, got rid of ':in ky:'.
#
# Revision 1.9  1996/05/21 01:28:20  tjchol01
# Removed 'ps', corrected irrelevant for umich, corrected separator
# printing.
#
# Revision 1.8  1996/05/20 19:29:41  tjchol01
# Parallel pipes.
#
# Revision 1.7  1996/05/18 04:09:38  tjchol01
# Don't print \$expired.  Experiment with \$relevant.
#
# Revision 1.6  1996/05/09 00:19:33  tjchol01
# Lines constaining only symbols are now deleted.
#
# Revision 1.5  1996/05/07 05:22:27  tjchol01
# Relevant and expiration.  Short notation for products.
#
# Revision 1.4  1996/05/04 05:27:21  tjchol01
# Default $flag value corrected.
#
# Revision 1.3  1996/05/04 05:16:18  tjchol01
# Improved capitalization.  Added severe.  Better input handling.
#
# Revision 1.2  1996/05/03 00:08:13  tjchol01
# Capitalization of sentences.
#
# Revision 1.1  1996/05/01 03:48:04  tjchol01
# Author removal.

use strict;
no strict "refs";

use POSIX 'strftime';
#use Sys::AlarmCall;
require 'timelocal.pl';

my $progname = 'Wea';
my $version = '$Id: wea,v 1.26 1996/12/10 07:35:15 tjchol01 Exp $';
my $description = 'Arguably Beautified Weather Forecast For Louisville';

# configuration section

# The author's web page and Internet electronic mail address.
my $my_url = 'http://mecca.spd.louisville.edu/~tjchol01/';
my $my_mail_url = 'mailto:tjchol01@starbase.spd.louisville.edu';
my $my_email = 'tjchol01@starbase.spd.louisville.edu';

# The URL to access the Web version of this program
my $web_url = 'http://mecca.spd.louisville.edu/~tjchol01/cgi-bin/wea.cgi';

# end of configuration section

my %recips = ("tjchol01" => ".*",			# mailing list
#	      "bprete01" => "lsr",
);

my $hiperiod = 5 * 60;				# reread every 5 minutes
my $loperiod = 60 * 60;				# reread every hour

my $timeout = 30;				# timeout after 30 sec

my $timediff = 12 * 60 * 60;			# 12 hours to expire
my $jefferson_zone = "030";			# zone number for Jefferson county
my $jefferson_county = "111";			# number of Jefferson county

# products
my $uky = 'http://www.ca.uky.edu/agcollege/agweather/public/';
my @ucurrent = (
         'SDFSWRKY',
         'KYNOW030',     # 'NOW',
         'LFP',
         'SDFSFPKY',
         'SDFSWSKY',
         'CLI',
         'AQI',
            );

my @uspec = (
         'POLLEN',
         'TOR',
         'SVR',
         'SVS',
         'SPS',
         'LSR',
         'RER',
         'PNS',
         'NPW',
         'SDFSLSKY',
             );

my @uadd = (
         'http://cirrus.sprl.umich.edu/wxnet/fcst/louisville.txt',
	 'gopher://spinaltap.micro.umn.edu/00/Weather/Kentucky/Louisville',
            );

my %MoY = ('jan', 1,
           'feb', 2,
           'mar', 3,
           'apr', 4,
           'may', 5,
           'jun', 6,
           'jul', 7,
           'aug', 8,
           'sep', 9,
           'oct', 10,
           'nov', 11,
           'dec', 12);


my (@urls, $arg, $full);
my $mailer = 0;
$full = "";
$arg = "";
while ($#ARGV >= 0) {
    if ($ARGV[0] eq "-m") {
	$mailer = 1;
    } else {
	($full, $arg) = ($ARGV[0] =~ /^(-?)(.*)$/);
    }
    shift;
}

# Am I being executed by httpd?  The $web variable executes code that depends
# upon the answer to this question.

my $web = defined $ENV{'REQUEST_METHOD'};

###############################################################################

my ($width, $tput_bold, $tput_inverse, $tput_normal, $tput_underline) =
    (78, "*", "*", "", "*");

if (!$web && !$mailer && -t STDOUT && $ENV{"TERM"} ne "emacs") {
    $width = `tput cols` - 1;
    $tput_bold = `tput bold`;
    $tput_inverse = `tput rev`;
    $tput_normal = `tput sgr0`;
    $tput_underline = `tput smul`;
    open (OUT, "| less -ifMrse") or die "No less?: $!\n";
} else {
    open (OUT, ">&STDOUT");
}
select (OUT); $| = 1;				# make it unbuffered

&prefix;


if ($arg) {
    if ($arg =~ /^[1-9]/) {			# numeric
        @urls = $uadd[$arg - 1];
    } else {					# explicit
        @urls = $arg;
    }
} else {
    if ($mailer) {
	@urls = @uspec;
    } else {
	@urls = (@ucurrent, @uspec);
    }
}

my $url;
my %times;
foreach $url (@urls) {
    $times{$url} = $^T - $timediff;
}


my %messages;
my %subjects;

my $period = $hiperiod;
my $periodcnt = 1;

do {
    print STDERR "READ: " . $period / 60 . "  " . `date` if $mailer;
    my ($recip, $valid);
    foreach $recip (keys %recips) {
	$messages{$recip} = "";
	$subjects{$recip} = "";
    }
    foreach $url (@urls) {
	my $fullurl = $url;
	if ($fullurl !~ /\//) {			# no / in name
	    if (length ($fullurl) == 3) {
		$fullurl = "sdf" . $fullurl . "sdf";
	    }
	    $fullurl = $uky . uc ($fullurl);
	}
	open ($url, "/usr/contrib/bin/lynx -dump $fullurl |") or die "Can't open: $!\n";
#    open ($url, "-|") || exec 'lynx', '-dump', $url;
#    open ($url, "timed-run 30 lynx -dump $url |") or die "Can't open: $!\n";
    }

    my $i = 0;
    foreach $url (@urls) {
	my @w1 = <$url>;
#	my @w = alarm_call ($timeout, 'read_url', $url);
	if ($#w1 < 3) {
	    $periodcnt = 1;			# make a retry soon
	    print "@w1\n";
	} else {
	    my @w;
	    if ($full eq "") {
		@w = &magiel (@w1);
	    } else {
		@w = @w1;
	    }
	    if (@w) {
		my $time;
		if ($w[$#w] =~ /^8\d+$/) {
		    $time = $w[$#w];
		    $#w--;
		} else {
		    $time = time () + 60 * 60;
		}
		$valid = 1;
		if (!$mailer || $time > $times{$url}) {
		    $times{$url} = $time;
		} else {
		    $valid = 0;
		}
		if ($mailer) {
		    if ($valid) {
			foreach $recip (keys %recips) {
			    if ($url =~ /$recips{$recip}/i) {
				$periodcnt = 1;
				$messages{$recip} .= ("-" x 70 . "\n") unless $i++ == 0;	# !!!
				$messages{$recip} .= join ('', @w);
				$subjects{$recip} .= lc ($url) . ", ";
			    }
			}
		    } else {
			$periodcnt++;
		    }
		    $period = $hiperiod * $periodcnt;
		    $period = $loperiod if $period > $loperiod;
		} else {
		    &hline unless $i++ == 0;
		    print OUT @w;
#		$main::result = join ("", @w);
#		write OUT;
		}
	    }
	}
    }


    foreach $recip (keys %recips) {
#	print $messages{$recip};
	if ($messages{$recip}) {
	    open (MAIL, "| mailx -s 'WEATHER: $subjects{$recip}' $recip");
	    print MAIL $messages{$recip};
	    close MAIL;
	}
    }

} until (!$mailer || (sleep ($period), 0));


if ($web) {
     print OUT "</pre>\n</body>\n</html>\n";
#     print OUT "--ThisRandomString--\n";
}

close (OUT);
exit 0;

#---------------------------------------------------------------
sub read_url {
    my ($url) = @_;
    my @w = <$url>;
#    close <$url>;
    return @w;
}
#---------------------------------------------------------------
sub magiel {
    my (@w) = @_;
    my ($off, $li, $swr, $now, $dotend, $emph, $relevant, $expired, $pollen);
    my @out = ();
    my $jeff;

    do {
	$li = $w[$#w];
	$li =~ s/\r//g;
    } until ($li !~ /^(NNNN|)$/ || ($#w--, 0));
    if ($li =~ /^ *[A-Za-z\/]+$/) {		# author
	$#w--;
    }

    $swr = $now = $dotend = $expired = $pollen = 0;
    $relevant = 1;
    my $subrelevant = 0;
    my $datok = 0;
    my $time;

    foreach (@w) {
        $emph = 0;
        s/\r//g;
        $_ = lc ($_);
        next if (/^\s*(|lmk scd 1200 nil|lexington|national weather service \w+ ky|issued by jefferson county air pollution control district|state extended forecast|\W*|(:in ky:)?ttaa00 .*|zczc .*)\s*$/); # don't print lines with these words only
        $swr ||= /^kentucky state weather roundup$/;
        $now ||= /^nowcast for jefferson county$/;
        $pollen ||= /^\s*pollen and mold count\s*$/;
	next if ($swr && (!/^louisville|fort knox|city\s*sky|199[6-9]$/ || /bowman field/));
	$relevant ||= /louisville/ && !/service in louisville/ || /jefferson/;

	if ($li = /^((ky|oh|in)[cz](\d+|all)|[a-z]{5,})[->]/.../^(.*\w)?$/) { # zones or names
	    if (/kyc/) {
		$jeff = $jefferson_county;
	    } else {
		$jeff = $jefferson_zone;
	    }
	    if (/ky[cz]all/ || /ky[cz].*$jeff/ || /louisville/ || /jefferson/) { # single zone or name
		$relevant = $subrelevant = 1;
	    }
	    while (/(\d{3})>(\d{3})/g) {	  # zone interval
		if ($1 <= $jeff && $2 >= $jeff) {
		    $relevant = $subrelevant = 1;
		    last;
		}
	    }
	    if ($li =~ /E0/ && !$subrelevant) {
		$relevant = 0;
	    }
#	    push (@out, "X " . $_);
	    next;
	}

	if ((/^\s*the national weather service data is provided/.../users who want this data/) ||
	    (/^\s*a courtesy of the university of kentucky/.../^very high \(alert\)  >150/)) {
	    next;
	}

	# date processing
	s/\/\d{3,4}\s+[ap]m\s+c[sd]t//;		  # get rid of central time zone
	if (/\s(19)?9[6-9]\s*(for .*)?$|^\w{3} .*e[sd]t$/) { # first date line
	    next if $datok;
	    $emph = 1;
	    my ($hour, $min, $apm, $zone, $weekday, $month, $day, $year);
	    my $date = $_;
	    $date =~ s/\.|:|,//g;		# remove punctuation
#	    push (@out, "$date\n");
	    if (($hour, $min, $apm, $zone, $weekday, $month, $day, $year) =
		($date =~ /(\d{1,2})(\d{2})\s?([ap]m)\s?(e[sd]t)?\s?(\w{3})?\s+(\w{3,10})\s+(\d{1,2})\s+(199[6-9])/)) {
		$month = substr ($month, 0, 3);	# for pollen
#                push (@out, "($hour, $min, $month, $MoY{$month}, $day, $year)\n");
		if ($apm eq "pm") {
		    $hour += 12 unless $hour >= 12;
		} else {
		    $hour -= 12 if $hour >= 12;
		}
		$datok = 1;
	    } elsif (($weekday, $month, $day, $hour, $min, $zone, $year) =
		     ($date =~ /^(\w{3})\s+(\w{3})\s+(\d{1,2})\s+(\d{1,2})(\d{2})\d{2}\s+(e[sd]t)?\s?(199[6-9])?$/)) {
		$year = 1996 if (!$year);
#                next unless $now;
		$datok = 1;
	    }

	    if ($datok) {
		$year -= 1900 if $year >= 1900;
		$time = timelocal (0, $min, $hour, $day, $MoY{$month} - 1, $year);
		if ($^T - $time > $timediff) {	  # current time
		    $expired = 1;
		    push (@out, "Expired: $_");
		    last;
		}
	    }
	}

	s/^[ .]?((rest of )?(the|now|this|monday|tuesday|wednesday|thursday|friday|saturday|sunday|today|tonight|overnight)( morning| evening| afternoon| night)?( (and|through) [a-z]+)?)\.\.\.([a-z\n])/&make_bold (ucfirst ($1) . ":") . " " . ucfirst($7)/e;
	s/^(\s*)\.\.\./$1/g;
	s/(\w)\.\.\.(\w|$)/$1, $2/g;
	s/^\.+//g;
	s/^weather conditions at //;
	if ($pollen) {
	    s/^\s*//;				  # flush pollens left
        }

        # capitalization
	s/((([a-z0-9]\.)  ?)|\.\n)([a-z])/"$3  " . ucfirst($4)/ge;
        if ($dotend) {				  # previous line ended in a '.'
            s/^(\s*)([a-z])/$1 . ucfirst($2)/e;
        }
        $dotend = /^\s*$|\.\s*$/;

        $emph ||= /extended forecast/i;
        if ($emph) {
            s/^(\s*)(.*)(\s)$/$1 . &make_underline($2) . $3/e;
        }
        push (@out, $_);
    }

    if (!$relevant) {
	return ();#"Irrelevant: skipping.\n");
    }
    elsif ($expired) {
	return ();
    }
    elsif ($datok) {
	return (@out, $time);
    }
    else {
	return @out;
    }
}


###############################################################################

sub make_bold {
    my ($s) = @_;
    if ($web) {
	return "<i>$s</i>";
    } else {
	return $tput_bold . $s . $tput_normal;
    }
}

sub make_underline {
    my ($s) = @_;
    if ($web) {
	return "<strong>$s</strong>";
    } else {
	return $tput_underline . $s . $tput_normal;
    }
}

sub do_title {
    my ($s) = @_;
    if ($web) {
	print OUT "<hr></pre><h2 align=center>$s</h2><pre>";
    } else {
	$s = $s . (' ' x int(($width-length($s))/2));
	$s =      (' ' x     ($width-length($s))   ) . $s;
	print OUT "$tput_inverse$tput_bold$s$tput_normal\n";
    }
}

sub hline {
    if ($web) {
	print OUT "<hr>";
    } else {
	print OUT "----------------------------------------------------------------\n"
    }
}

###############################################################################

### This is breaking emacs font lock; I'm putting it at the end and out of
### the way of the real code. :)

sub prefix {
    if (!$web) {
	do_title ("$progname version $version");
	do_title ($description);
        do_title ("Copyright (C) 1995, 1996 by Tomasz J. Cholewo");
	do_title ("<$my_email>");
	do_title ("World Wide Web: $web_url");
    } else {
        my $date = &strftime ('%a %d-%b-%Y, %H:%M:%S %Z', localtime);
        print OUT <<"--- END OF WEB INSERT ---";
Content-type: text/html
Pragma: no-cache

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN">
<HTML>
<HEAD>
<TITLE>$progname</TITLE>
</HEAD>
<BODY BGCOLOR=\"#ffffff\">

<H1 ALIGN=CENTER>$progname</H1>

<P ALIGN=CENTER>
$description<BR>
Version $version (WWW implementation)<BR>
Copyright &copy; 1995, 1996 <A HREF="$my_url">Tomasz J. Cholewo</A>
(<A HREF="$my_mail_url"><TT>$my_email</TT></A>)

<P ALIGN=CENTER>
This instance of $progname was executed on <strong>$date</strong>.<br>
<a href="wea.cgi">Select this link</a>, or use your browser's
``Reload'' function to run it again and get an up-to-date status.

<pre>
--- END OF WEB INSERT ---
    }
}