#!/usr/local/bin/perl

setpriority(0,0,getpriority(0,0)+4);   # nice the process

$| = 1;  # force STDOUT to be unbuffered

# Try to ignore signals

@sigs = split(/ /,`kill -l`);
sub do_nothing { }
foreach $s (@sigs) {
    $SIG{$s} = 'do_nothing';
} 

$UseLocking = 1;
$LOCK_SH =  1;    # shared lock 
$LOCK_EX =  2;    # exclusive lock 
$LOCK_NB =  4;    # don't block when locking
$LOCK_UN =  8;    # unlock

# Maximum number of times to try to lock the file.
# Each try is .1 second.

$MaxTries = 1;

$ARCHIVE = "/data1/WWW/Tropical/StrikeProb/Archive";  # Archive directory
$ZIPDIR = "/data1/WWW/Tropical/Zip"; # Zip code directory

require "/data1/WWW/Tropical/Bin/StrikeProb.pl";

if (&MethGet) {
   $in = $ENV{'QUERY_STRING'};
} elsif ($ENV{'REQUEST_METHOD'} eq "POST") {
   read(STDIN,$in,$ENV{'CONTENT_LENGTH'});
}
@in = split(/&/,$in);

foreach $i (0 .. $#in) {
   # Convert plus's to spaces
   $in[$i] =~ s/\+/ /g;
   # Split into key and value.  
   ($key, $val) = split(/=/,$in[$i],2); # splits on the first =.
   # Convert %XX from hex numbers to alphanumeric
   $key =~ s/%(..)/pack("c",hex($1))/ge;
   $val =~ s/%(..)/pack("c",hex($1))/ge;
   # Associate key and value
   $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
   $in{$key} .= $val;
}

($sec,$min,$hour,$mday,$mon,$year) = gmtime;
$mon++;
if ($sec < 10) {$sec="0$sec"};
if ($min < 10) {$min="0$min"};
if ($hour < 10) {$hour="0$hour";}
if ($mday < 10) {$mday="0$mday";}
if ($mon < 10) {$mon="0$mon";}
if ($year >= 96) {$yearname = 1900+$year;} else {$yearname = 2000+$year;}
$year = substr($yearname,2,2);

$latitude = $in{'latitude'};
$longitude = $in{'longitude'};
$city = $in{'city'};
$locstring = $in{'location'};
$zip = $in{'zip'};
$smallscreen = $in{'smallscreen'};
$wml = $in{'wml'};
$goslow = $in{'slow'};
# Go fast unless slow is specifically set.
if (!$goslow) {$gofast=1;} else {$gofast=0;}
$file = "/data1/WWW/Tropical/Data/tropical$year";

if ($smallscreen) {$ARCHIVE = $ARCHIVE."/.Clip";}
if ($wml) {$ARCHIVE = $ARCHIVE."/.WML";}

# Check to see if we can\should output to an archive file

$UseArchiveFile = 0;
$recompute = 1;

# Parse the zip code into a latitude and longitude if zip passed in

if ($zip =~ /^\s*(\d\d\d\d\d)/) {
   my $loczip = $1;
   my $zipfile = $ZIPDIR."/"."zip".substr($loczip,0,2).".txt";
   if (open(ZIPFILE,$zipfile)) {
     while (<ZIPFILE>) {
        my @line = split(" ");
        if ($loczip == $line[0]) {
           $latitude = int($line[1]) + ($line[1]-int($line[1]))*60/100;    # dd.mm
           $longitude = int($line[2]) + ($line[2]-int($line[2]))*60/100;   # dd.mm
           my $ilastcity = $#line-1;
           $locstring = join(" ",@line[3..$ilastcity]).", ".$line[$#line];
        }        
     }
   }
}

if ($city =~ /\w+/) {
  $fcity = $city;
  $fcity =~ s/\s//;
}
elsif (&ISNUMBER($latitude) && &ISNUMBER($longitude)) {
   if ($latitude >= 0) {
      $ns = 'N';
      $flat = int($latitude);
      $flatmin = int(($latitude-$flat)*100+0.5);
   } else {
      $ns = 'S';
      $flat = int(-$latitude);
      $flatmin = int((-$latitude-$flat)*100+0.5);
   }
   if (length($flat) < 2) {$flat = '0'.$flat;}
   if (length($flatmin) < 2) {$flatmin = '0'.$flatmin;}
   if ($longitude >= 0) {
      $ew = 'W';
      $flon = int($longitude);
      $flonmin = int(($longitude-$flon)*100+0.5);
   } else {
      $ew = 'E';
      $flon = int(-$longitude);
      $flonmin = int((-$longitude-$flon)*100+0.5);
   }
   if (length($flon) < 2) {$flon = '0'.$flon;}
   if (length($flonmin) < 2) {$flonmin = '0'.$flonmin;}
   $fcity = $flat.$flatmin.$ns.$flon.$flonmin.$ew;
   if ($locstring =~ /\w+/) {$fcity = $fcity."_".$locstring;}
}

if (defined($fcity)) {
   my $extension = ".html";
   if ($wml) {$extension=".wml";}
   $fcity = $fcity . $smallscreen;
   if (!$gofast) {$fcity = $fcity . "_slow";}
   $fcity =~ s/\W//g;
   $afile = "$ARCHIVE/\L$fcity".$extension;  # Get file name: force city to be lower case  
   $afile =~ s/\s+//g;           # Remove any whitespace
   if ((-f $afile) && (-s $afile)) {              # does it exist already?
      if ((-r $afile) && (-w $afile)) {  # $afile exists, is it read/writeable?
         $UseArchiveFile = 1;         # It's ok use it
         if (((-M $afile) < (-M $file)) && ((-M $afile) <= 1)) { # Is it out of date?
            $recompute = 0;
         } else {
            $recompute = 1;
         }
      }
   } else {                        # $afile doesn't exist
      if ((-r $ARCHIVE) && (-w $ARCHIVE)) {   # Can we write to the directory?
         $UseArchiveFile = 1;         # It's ok, use it
         $recompute = 1;              # didn't exist, so must recompute
      }
   }
} else {  # If $fcity is not defined, then we got bad input
   if ($wml) {
      print "Content-type: text/vnd.wap.wml\n\n";
      print "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
      print "<\!DOCTYPE wml PUBLIC \"-//PHONE.COM//DTD WML 1.1//EN\"\n";
      print "\"http://www.phone.com/dtd/wml11.dtd\">\n";
      print "<wml>\n";
      print "  <head>\n";
      print "    <meta forua=\"true\" http-equiv=\"Cache-Control\" content=\"max-age=3600\"/>\n";
      print "    <meta forua=\"true\" http-equiv=\"Cache-Control\" content=\"must-revalidate\"/>\n";
      print "  </head>\n";
      print "<card id=\"sperror\" title=\"Strike Probabilities\">\n";
      print "<p>Error: Bad input.  If you input a ZIP code, your ZIP may \n";
      print "not be in the database.  Try a different, nearby, ZIP code.\n</p>";
      print "<p><anchor>Prev<prev/></anchor></p>\n";
      print "</card></wml>\n";
   } else {
      print "Content-type: text/html\n\n";
      print "<HTML><HEAD><TITLE>Strike Probabilities</TITLE>\n";
      print "<meta name=\"palmcomputingplatform\" content=\"true\">\n";
      print "<!-- (C) $yearname by Thomas R. Metcalf.  All rights reserved. -->\n";
      print "</HEAD><BODY TEXT=\"#000000\"  BGCOLOR=\"#FFFFE0\" LINK=\"#0000FF\" VLINK=\"#FF0000\">\n";
      print "Error: Bad input.  If you input a ZIP code, your ZIP may \n";
      print "not be in the database.  Try a different, nearby, ZIP code.\n";
      if (!$smallscreen) {
         print "<P>\n";
         print '<A href="/Tropical/tropical.html">';
         print '<IMG SRC="/Gif/home.gif" ALT="Home" BORDER=0></A>';
         print '<A href="/Tropical/StrikeProb.html">';
         print '<IMG SRC="/Gif/back.gif" ALT="Back" BORDER=0>';
      }
      print "\n</BODY></HTML>";
   }
   exit;
}

# send the header to STDOUT

if ($wml) {
   print "Content-type: text/vnd.wap.wml\n\n";
   print "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
   print "<\!DOCTYPE wml PUBLIC \"-//PHONE.COM//DTD WML 1.1//EN\"\n";
   print "\"http://www.phone.com/dtd/wml11.dtd\">\n";
} else {
   print "Content-type: text/html\n\n";
}

# Now print to archive if requested, otherwise leave output to STDOUT

if ($UseArchiveFile && $recompute) {
   if (!open(AFILE,"+>$afile")) {
      $UseArchiveFile = 0;
      $recompute = 1;
   } else {
      $lockerror = &LockFile(AFILE,$LOCK_EX);  # exclusive lock for updates
      if ($lockerror) {
         close(AFILE);
         $UseArchiveFile = 0;  # can't get lock ... just print to STDOUT
         $recompute = 1;
      } else {
         chmod 0666,"$afile";
         select(AFILE);        # Send output to AFILE
         $| = 1;  # force AFILE to be unbuffered
      }
   }
}

# Do the strike probability calculation.
# Check the load on the machine.  Abort if too busy.

if ($recompute || !$UseArchiveFile) {
   $sproberrcheck = &ComputeSProb($city,$latitude,$longitude,$yearname,$mday,$hour,$min,$sec,$locstring,$smallscreen,$wml,$gofast);
}

# Test, read and print the archive file, if requested.
# Make sure the results are printed even if it means recomputing the 
# strike probabilities.

if ($UseArchiveFile) { 
   if ($recompute) {
      &UnlockFile(AFILE);
      close(AFILE);
      if ($sproberrcheck) {unlink("$afile");}  # Machine was too busy
   }
   select(STDOUT);        # Use STDOUT to send HTML to browser
   if (! open(AFILE,"<$afile") ) {
      # File access error ... recompute and send results directly to STDOUT
      if (-f $afile) {unlink("$afile");}
      &ComputeSProb($city,$latitude,$longitude,$yearname,$mday,$hour,$min,$sec,$locstring,$smallscreen,$wml,$gofast);  # Recompute and send output to STDOUT
   } else {
      $lockerror = &LockFile(AFILE,$LOCK_SH);  # shared lock for reads
      if ($lockerror) {
         # File read lock error ... recompute and send results directly to STDOUT 
         &ComputeSProb($city,$latitude,$longitude,$yearname,$mday,$hour,$min,$sec,$locstring,$smallscreen,$wml,$gofast);  # Recompute and send output to STDOUT
      } else {
         #  All's well ... read and print the archived file
	 local($line) = 0;
	 local($BeginError) = 0;
         while (<AFILE>) {
            print;
            if ($line eq 0) {
               if (!/\<(HT|W|\?X|X)ML/i) {   # Found an incomplete file
		   $BeginError = 1;
               }
            }
            if (eof(AFILE)) {
               if (!/\<\/(HT|W|\?X|X)ML\>/i || $BeginError) {   # Found an incomplete file
                  if ($wml) {
                     print "<p>INCOMPLETE DATA ... PLEASE TRY AGAIN</p></card></wml>";
                  } else {
                     print "</TABLE><P><H2>INCOMPLETE DATA ... PLEASE TRY AGAIN</H2></HTML>";
                  }
                  unlink("$afile");
               }
            }
            ++$line;
         }
         &UnlockFile(AFILE);
      }
      close(AFILE);
   }
}


exit;


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

sub ComputeSProb {

   # compute the strike probabilities and output the HTML.
   # REturns 0 on success, -1 on failure

   local($city,$latitude,$longitude,$yearname,$mday,$hour,$min,$sec,$locstring,$smallscreen,$wml,$gofast) = @_;
   local($i,$monname,$tcity,$return,@latitude,@longitude,@city);

   @ldavg = &LDAVG();
   if ($ldavg[0] > 2.25) {
      if ($wml) {
         print "<wml>\n";
         print "  <head>\n";
         print "    <meta forua=\"true\" http-equiv=\"Cache-Control\" content=\"max-age=3600\"/>\n";
         print "    <meta forua=\"true\" http-equiv=\"Cache-Control\" content=\"must-revalidate\"/>\n";
         print "  </head>\n";
         print "<card id=\"toobusy\" title=\"busy\">\n";
      }
      print "<p>Too busy to run the Strike Probability program.  Try again later.</p>\n";
      if ($wml) {
         print "</card></wml>\n";
      }
      if (!$smallscreen && !$wml) {
         print "<P>Archived probabilities are located at <A HREF=\"/Tropical/StrikeProb/Archive/\">http://www.solar.ifa.hawaii.edu/Tropical/StrikeProb/Archive/</A>.\n";
      }
      $return = -1;
   } else {
      if ($wml) {
         print "<wml>\n";
         print "  <head>\n";
         print "    <meta forua=\"true\" http-equiv=\"Cache-Control\" content=\"max-age=3600\"/>\n";
         print "    <meta forua=\"true\" http-equiv=\"Cache-Control\" content=\"must-revalidate\"/>\n";
         print "  </head>\n";
         print "<card id=\"StrikeProb\" title=\"Strike Probabilities\">\n";
         print "<p align=\"center\"><strong>$yearname-$monname-$mday $hour:$min:$sec UT</strong></p>\n";
      } else {
         print "<HTML><HEAD><TITLE>Strike Probabilities</TITLE>\n";
         if ($smallscreen) {
            print "<meta name=\"palmcomputingplatform\" content=\"true\">\n";
            print "</HEAD><BODY TEXT=\"#000000\"  BGCOLOR=\"#FFFFFF\">\n";
         } else {
            print "<!-- (C) $yearname by Thomas R. Metcalf.  All rights reserved. -->\n";
            print "</HEAD><BODY TEXT=\"#000000\"  BGCOLOR=\"#FFFFE0\" LINK=\"#0000FF\" VLINK=\"#FF0000\">\n";
         }
         print "<P ALIGN=CENTER><H3 ALIGN=CENTER>\n";
         $monname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)[(gmtime)[4]];
         print "$yearname-$monname-$mday $hour:$min:$sec UT\n";
         print "</H3></P>\n";
      }

      if ($city eq "") {
         $latitude =~ s/\s\s//g;
         $latitude =~ s/\s\s/\s/g;
         $latitude =~ s/,,/,/g;
         $latitude =~ s/,\s/,/g;
         $latitude =~ s/\s,/,/g;
         @latitude = split(/[\,]/,$latitude);
         $longitude =~ s/\s\s/\s/g;
         $longitude =~ s/,,/,/g;
         $longitude =~ s/\s,/,/g;
         $longitude =~ s/,\s/,/g;
         @longitude = split(/\,/,$longitude);
         for ($i=0; $i<=$#latitude; ++$i) {
            &StrikeProb'StrikeProb($latitude[$i],$longitude[$i],$file,$locstring,$smallscreen,$wml,$gofast);
         }
      } else {
         $city =~ s/\s\s/ /g;
         $city =~ s/,,/,/g;
         $city =~ s/\s,/,/g;
         $city =~ s/,\s/,/g;
         @city = split(/\,/,$city);
         foreach $tcity (@city) {
            &StrikeProb'StrikeProb($tcity,"junk",$file,$locstring,$smallscreen,$wml,$gofast);
         }
      }

      if ($wml) {
         print "<p><anchor>Warning! These data may not be accurate.<go href=\"/Tropical/HTML/WML/index.wml#warning\"/></anchor></p>\n";
         print "</card></wml>\n"
      } else {
         if ($smallscreen) { 
            print "<a href=\"file:Hurricane.pqa/warning.html\">Warning!</a>  These data may not be accurate.\n";
         } else {
            print "<P><HR><P>\n";
            print "<A HREF=\"/Tropical/README.html\"><IMG SRC=\"/Gif/warning.gif\" BORDER=0>Warning!</A> These data may not be accurate.  Do not rely on them for life or death decisions or decisions relating to the protection of property.  <STRONG>The strike probabilities have no official status and should not be used for emergency response decision-making under any circumstances.</STRONG><P><A HREF=\"/Tropical/Bin/Docs/StrikeProbability.ps\">Description</A> of the strike probabilty calculation (168 kB PostScript file).  <A HREF=\"/Tropical/Bin/Docs/StrikeProbability.pdf\">(PDF version)</a>.\n";
            print "<P>\n";

            print '<A href="/Tropical/tropical.html"><IMG SRC="/Gif/home.gif" ALT="Home" BORDER=0></A>';
            print '<A href="/Tropical/StrikeProb.html"><IMG SRC="/Gif/back.gif" ALT="Back" BORDER=0></A>';
            print '<ADDRESS><A HREF="mailto:metcalf@akala.ifa.hawaii.edu">metcalf@akala.ifa.hawaii.edu</A></ADDRESS>';
         }
         print "</BODY></HTML>\n";
      }

      $return = 0

   }

   $return;

}

# MethGet
# Return true if this cgi call was using the GET request, false otherwise
sub MethGet {
  return ($ENV{'REQUEST_METHOD'} eq "GET");
}


sub LDAVG {

   # Get the current load average

   local($W) = "w";  # w command
   local(@ldavg);

   if (open(W,$W."|")) {

      while (<W>) {
         if (/load\s+average\:\s*(\d+\.\d*)\s*,\s*(\d+\.\d*)\s*,\s*(\d+\.\d*)\s*$/i) {;
            $ldavg[0] = $1;
            $ldavg[1] = $2;
            $ldavg[2] = $3;
            last;
         }
      }
      close W;
      @ldavg;
   } else {(0,0,0);}
   
}

sub LockFile {

    local(*FILE,$locktype) = @_;
    local($TrysLeft) = $MaxTries;

    if ($UseLocking) {
	# Try to get a lock on the file
	while ($TrysLeft--) {
	    
	    # Try to use locking, if it doesn't use locking, the eval would
	    # die.  Catch that, and don't use locking.

	    # Try to grab the lock with a non-blocking (4) exclusive (2) lock.
	    # (4 | 2 = 6)
	    $lockresult = eval("flock(FILE,$LOCK_NB|$locktype)");

	    if ($@) {
		$UseLocking = 0;
		last;
	    }

	    if (!$lockresult) {
		select(undef,undef,undef,0.1); # Wait for 1/10 sec.
	    } else {
		last;		# We have gotten the lock.
	    }
	}
    } else {return -1;}

    if ($TrysLeft >= 0) {
	# Success!
	return 0;
    } else {
	return -1;
    }
}


sub UnlockFile {
    local(*FILE) = @_;

    if ($UseLocking) {
	flock(FILE,$LOCK_UN);			# Unlock the file.
    }
}

sub ISNUMBER {

   # Is the argument a number, e.g. 1.0, .1, 1, 1e4, 1.0e4, etc.?
   # Returns true or false.

   $_[0] =~ /^\s*(\+|-|)(\d+|\d+\.\d*|\d*\.\d+)(e\d+|)\s*$/i;
}